(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "24-Jul-87 12:36:47" {DSK}<LISPFILES>MATT>FTPSERVERPATCH.;7 16882
changes to%: (FNS FTPSERVER \NEGOTIATED-FTPSERVER.TOP \SFTP.WHENCLOSED \SFTP.PLIST.FROM.FILE
\FTPSERVER.TOP NEGOTIATED-FTPSERVER \SFTP.COMMANDLOOP)
(FILEVARS FTPSERVERPATCHCOMS)
(VARS FTPSERVERPATCHCOMS)
(VARIABLES \PUPSOCKET.NEGOTIATED.CONNECTION)
previous date%: "21-Jul-87 18:52:28" {DSK}<LISPFILES>MATT>FTPSERVERPATCH.;2)
(* "
Copyright (c) 1987 by Matt Heffron & XEROX Corporation. All rights reserved.
")
(PRETTYCOMPRINT FTPSERVERPATCHCOMS)
(RPAQQ FTPSERVERPATCHCOMS ((DECLARE%: DOCOPY FIRST (FILES FTPSERVER))
(FNS FTPSERVER NEGOTIATED-FTPSERVER \FTPSERVER.TOP
\NEGOTIATED-FTPSERVER.TOP \SFTP.COMMANDLOOP \SFTP.OPENFILE.FROM.PLIST
\SFTP.PLIST.FROM.FILE \SFTP.WHENCLOSED)
(CONSTANTS (\PUPSOCKET.NEGOTIATED.CONNECTION 63))
(DECLARE%: DONTCOPY (MACROS .IFDESIRED.)
(FILES (LOADCOMP)
DPUPFTP BSP))
(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
FTPSERVERPATCH)))
(DECLARE%: DOCOPY FIRST
(FILESLOAD FTPSERVER)
)
(DEFINEQ
(FTPSERVER
[LAMBDA (FTPDEBUG) (* ; "Edited 24-Jul-87 12:36 by Matt Heffron")
(* ;; "Start the process that listens for the requests for Negotiated sockets")
(ADD.PROCESS (LIST (FUNCTION \FTPSERVER.TOP)
(KWOTE FTPDEBUG))
'NAME
'FTPSERVER
'RESTARTABLE
'HARDRESET)
(* ;; "Then start a FTP server on the STANDARD socket.")
(NEGOTIATED-FTPSERVER \PUPSOCKET.FTP])
(NEGOTIATED-FTPSERVER
[LAMBDA (SOCKET#) (* ; "Edited 22-Jul-87 11:56 by Matt Heffron")
(if (NOT (FIXP SOCKET#))
then (SETQ SOCKET# \PUPSOCKET.FTP))
(ADD.PROCESS (LIST (FUNCTION \NEGOTIATED-FTPSERVER.TOP)
SOCKET#)
'NAME
'NEGOTIATED-FTPSERVER
'RESTARTABLE
'HARDRESET])
(\FTPSERVER.TOP
[LAMBDA (FTPDEBUG)
(DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 22-Jul-87 11:55 by Matt Heffron")
(LET (SOCKET PUP NEWFTPSOCKET)
(COND
(FTPDEBUG [COND
((OR (EQ FTPDEBUG T)
(LISTP FTPDEBUG))
(SETQ FTPDEBUGLOG (GETSTREAM (CREATEW (LISTP FTPDEBUG)
"FTP Server traffic")
'OUTPUT))
(WINDOWPROP FTPDEBUGLOG 'PAGEFULLFN (FUNCTION NILL))
(DSPSCROLL 'ON FTPDEBUGLOG)
(DSPFONT '(GACHA 8) FTPDEBUGLOG))
(T (SETQ FTPDEBUGLOG (GETSTREAM FTPDEBUG 'OUTPUT]
(printout FTPDEBUGLOG "FTP Server started at " (DATE)
T T)
(RESETSAVE FTPDEBUGFLG T)))
(SETQ SOCKET (OPENPUPSOCKET \PUPSOCKET.NEGOTIATED.CONNECTION 'ACCEPT))
(do (SETQ PUP (GETPUP SOCKET T))
(SWAPPUPPORTS PUP)
(SETQ NEWFTPSOCKET (PUPSOCKETNUMBER (OPENPUPSOCKET)))
(NEGOTIATED-FTPSERVER NEWFTPSOCKET)
(replace PUPSOURCESOCKET of PUP with NEWFTPSOCKET)
(SENDPUP SOCKET PUP])
(\NEGOTIATED-FTPSERVER.TOP
[LAMBDA (SOCKET#)
(DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 22-Jul-87 13:19 by Matt Heffron")
(LET (SOCKET INSTREAM EVENT SAVER)
(if FTPDEBUGLOG
then (printout FTPDEBUGLOG "Negotiated FTP Server started at " (DATE)
" on Socket #"
(OCTALSTRING SOCKET#)
T T))
(RESETSAVE NIL (SETQ SAVER (LIST [FUNCTION (LAMBDA (SOC)
(AND SOC (CLOSERTPSOCKET SOC 0]
NIL)))
(do (SETQ SOCKET (OPENRTPSOCKET NIL '(SERVER RETURN) (OPENPUPSOCKET SOCKET# T)
NIL))
(RPLACA (CDR SAVER)
SOCKET)
(SETQ EVENT (fetch RTPEVENT of SOCKET))
(until (EQ (fetch RTPSTATE of SOCKET)
\STATE.OPEN) do (AWAIT.EVENT EVENT))
[COND
((SETQ INSTREAM (CREATEBSPSTREAM SOCKET NIL (FUNCTION \SFTP.ERRORHANDLER)
(IMIN \FTP.IDLE.TIMEOUT MAX.SMALLP)
(FUNCTION \SFTP.TIMEOUTFN)
(FUNCTION \SFTP.WHENCLOSED)))
(if FTPDEBUGLOG
then (PUTSTREAMPROP INSTREAM 'FTP.DEBUG.PREFIX (CONCAT "[" (OCTALSTRING SOCKET#)
"] ")))
(if (NEQ SOCKET# \PUPSOCKET.FTP)
then (PUTSTREAMPROP INSTREAM 'FTP.SERVER.PROCESS (THIS.PROCESS)))
(NLSETQ (RESETLST [RESETSAVE NIL (if (EQ SOCKET# \PUPSOCKET.FTP)
then `(CLOSEBSPSTREAM ,INSTREAM 0)
else `(PROGN (CLOSEBSPSTREAM ,INSTREAM 0)
(DEL.PROCESS ,(THIS.PROCESS]
(* ;; "(RPLACA (CDR SAVER) NIL)")
(if FTPDEBUGLOG
then (printout FTPDEBUGLOG T "[" (OCTALSTRING SOCKET#)
"] Connection open with "
(PORTSTRING (fetch FRNPORT of SOCKET)
(\MAKENUMBER (fetch FRNSOCKETHI of SOCKET)
(fetch FRNSOCKETLO of SOCKET)))
T))
(\SFTP.COMMANDLOOP INSTREAM (BSPOUTPUTSTREAM INSTREAM]
repeatwhile (EQ SOCKET# \PUPSOCKET.FTP])
(\SFTP.COMMANDLOOP
[LAMBDA (INS OUTS)
(DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 22-Jul-87 11:10 by Matt Heffron")
(bind MARK repeatwhile (SELECTC (SETQ MARK (FTPGETMARK INS))
((MARK# VERSION)
(\SFTP.VERSION INS OUTS))
((MARK# RETRIEVE)
(\SFTP.RETRIEVE INS OUTS))
((MARK# NEW-STORE)
(\SFTP.STORE INS OUTS))
((MARK# STORE)
(\SFTP.STORE INS OUTS T))
((MARK# NEW-ENUMERATE)
(\SFTP.ENUMERATE INS OUTS T))
((MARK# ENUMERATE)
(\SFTP.ENUMERATE INS OUTS))
((MARK# EOC)
T)
((MARK# COMMENT)
(OR (\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG)
(\SFTP.PROTOCOL.ERROR INS OUTS)))
((LIST (MARK# YES)
(MARK# NO)
(MARK# HERE-IS-PLIST)
(MARK# HERE-IS-FILE))
(\SFTP.PROTOCOL.ERROR INS OUTS))
(0 (* ; "timedout")
NIL)
(PROGN (FTPPUTMARK OUTS (MARK# NO))
(FTPPUTCODE OUTS \NO.UNIMPLEMENTED)
(PRIN3 "Unimplemented command " OUTS)
(PRIN3 (MKSTRING MARK)
OUTS)
(.EOC. OUTS)
T])
(\SFTP.OPENFILE.FROM.PLIST
[LAMBDA (PLIST ACCESS OUTS DESIREDPROPS) (* ; "Edited 21-Jul-87 16:42 by Matt Heffron")
(* ;
"Opens file from user's PLIST, or answers NO and returns NIL")
(PROG (FILE FILENAME PIECES ERROR MYPLIST)
(for PAIR in PLIST do (SELECTQ (CAR PAIR)
(SERVER-FILENAME
(SETQ FILENAME (CADR PAIR)))
(DEVICE [push PIECES 'HOST (COND
((EQ (NTHCHARCODE (CADR PAIR)
-1)
(CHARCODE %:))
(SUBSTRING (CADR PAIR)
1 -2))
(T (CADR PAIR])
(DIRECTORY (push PIECES 'DIRECTORY (CADR PAIR)))
(NAME-BODY (push PIECES 'BODY (CADR PAIR)))
(VERSION (push PIECES 'VERSION (if (STRING.EQUAL (CADR PAIR)
"H")
then ""
else (CADR PAIR))))
(TYPE [push MYPLIST (LIST 'TYPE (MKATOM (U-CASE (CADR PAIR])
((CREATIONDATE CREATION-DATE)
(push MYPLIST (LIST 'CREATIONDATE (CADR PAIR))))
((END-OF-LINE-CONVENTION EOLCONVENTION EOC)
[push MYPLIST (LIST 'EOLCONVENTION (U-CASE (CADR PAIR])
(SIZE [push MYPLIST (LIST 'LENGTH (MKATOM (CADR PAIR])
NIL))
(SETQ FILENAME (COND
[(NULL FILENAME)
(PACKFILENAME.STRING (NCONC PIECES (LIST 'HOST FTPSERVER.DEFAULT.HOST]
((NULL (FILENAMEFIELD FILENAME 'HOST))
(PACKFILENAME.STRING 'HOST FTPSERVER.DEFAULT.HOST 'BODY FILENAME))
(T FILENAME)))
(RETURN (COND
([NLSETQ (SETQ FILE (COND
[(EQ ACCESS 'ENUMERATE)
(SETQ FILENAME (DIRECTORY.FILL.PATTERN FILENAME))
(CONS FILENAME (\GENERATEFILES FILENAME DESIREDPROPS
'SORT]
(T (OPENSTREAM FILENAME ACCESS NIL NIL
(CONS 'SEQUENTIAL MYPLIST]
FILE)
(T (\SFTP.MARK.ERROR OUTS)
(.EOC. OUTS)
NIL])
(\SFTP.PLIST.FROM.FILE
[LAMBDA (FILE NEW DESIREDPROPS FILEOPENP GENERATOR) (* ; "Edited 22-Jul-87 12:08 by Matt Heffron")
(* Generates a PLIST from FILE. NEW is true if file is being written anew
DESIREDPROPS may restrict what we send)
(PROG ([PIECES (UNPACKFILENAME.STRING (COND
((type? STREAM FILE)
(FULLNAME FILE))
(T FILE]
INFOFN INFOHANDLE HOST DIR NAME EXT VERSION AUTHOR TYPE FULLNAME PLIST)
(COND
(GENERATOR (SETQ INFOFN (FUNCTION \GENERATEFILEINFO))
(SETQ INFOHANDLE GENERATOR))
(T (SETQ INFOFN (FUNCTION GETFILEINFO))
(SETQ INFOHANDLE FILE)))
(for TAIL on PIECES by (CDDR TAIL)
do (SELECTQ (CAR TAIL)
(HOST [COND
((EQ (MKATOM (CADR TAIL))
FTPSERVER.DEFAULT.HOST)
(RPLACA (CDR TAIL)))
(T (SETQ HOST (CADR TAIL])
(DIRECTORY (SETQ DIR (CADR TAIL)))
(NAME (SETQ NAME (CADR TAIL)))
(EXTENSION (SETQ EXT (CADR TAIL)))
(VERSION (SETQ VERSION (CADR TAIL)))
NIL))
[SETQ PLIST (NCONC (.IFDESIRED. SERVER-FILENAME (PACKFILENAME.STRING PIECES))
(.IFDESIRED. NAME-BODY (COND
(EXT (CONCAT NAME "." EXT))
(T NAME)))
(.IFDESIRED. VERSION VERSION)
(.IFDESIRED. END-OF-LINE-CONVENTION 'CR)
(AND DIR (.IFDESIRED. DIRECTORY DIR))
(AND HOST (.IFDESIRED. DEVICE HOST]
[COND
((NOT NEW)
(SETQ FULLNAME (PACKFILENAME.STRING PIECES))
(SETQ PLIST (NCONC PLIST [.IFDESIRED. TYPE (SETQ TYPE (OR (APPLY* INFOFN INFOHANDLE
'TYPE)
(\GETFILETYPE FILE FILEOPENP]
(AND (EQ TYPE 'BINARY)
(LIST (LIST 'BYTE-SIZE 8)))
[.IFDESIRED. CREATION-DATE (PROGN
(* ;; "(APPLY* INFOFN INFOHANDLE 'CREATIONDATE)")
(GETFILEINFO FULLNAME '
CREATIONDATE]
[.IFDESIRED. WRITE-DATE (PROGN
(* ;; "(APPLY* INFOFN INFOHANDLE 'WRITEDATE)")
(GETFILEINFO FULLNAME 'WRITEDATE]
[.IFDESIRED. READ-DATE (PROGN
(* ;; "(APPLY* INFOFN INFOHANDLE 'READDATE)")
(GETFILEINFO FULLNAME 'READDATE]
[.IFDESIRED. SIZE (PROGN
(* ;; "(APPLY* INFOFN INFOHANDLE 'LENGTH)")
(GETFILEINFO FULLNAME 'LENGTH]
(.IFDESIRED. AUTHOR (APPLY* INFOFN INFOHANDLE 'AUTHOR]
(RETURN PLIST])
(\SFTP.WHENCLOSED
[LAMBDA (STREAM)
(DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 22-Jul-87 13:18 by Matt Heffron")
(LET [(SERVERPROC (GETSTREAMPROP STREAM 'FTP.SERVER.PROCESS]
(if FTPDEBUGLOG
then (printout FTPDEBUGLOG T (GETSTREAMPROP STREAM 'FTP.DEBUG.PREFIX)
"Connection closed" T))
(if SERVERPROC
then (DEL.PROCESS SERVERPROC])
)
(DECLARE%: EVAL@COMPILE
(RPAQQ \PUPSOCKET.NEGOTIATED.CONNECTION 63)
(CONSTANTS (\PUPSOCKET.NEGOTIATED.CONNECTION 63))
)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
[PUTPROPS .IFDESIRED. MACRO ((PROP . LISTFORM)
(AND (OR (NULL DESIREDPROPS)
(FMEMB 'PROP DESIREDPROPS))
(PROG ((PROPVAL . LISTFORM))
(RETURN (AND PROPVAL (LIST (LIST 'PROP PROPVAL]
)
(FILESLOAD (LOADCOMP)
DPUPFTP BSP)
)
(PUTPROPS FTPSERVERPATCH FILETYPE :TCOMPL)
(PUTPROPS FTPSERVERPATCH MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
(PUTPROPS FTPSERVERPATCH COPYRIGHT ("Matt Heffron & XEROX Corporation" 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1448 16093 (FTPSERVER 1458 . 1993) (NEGOTIATED-FTPSERVER 1995 . 2401) (\FTPSERVER.TOP
2403 . 3763) (\NEGOTIATED-FTPSERVER.TOP 3765 . 6628) (\SFTP.COMMANDLOOP 6630 . 8656) (
\SFTP.OPENFILE.FROM.PLIST 8658 . 12014) (\SFTP.PLIST.FROM.FILE 12016 . 15629) (\SFTP.WHENCLOSED 15631
. 16091)))))
STOP