(FILECREATED "16-Nov-84 16:12:16" {ERIS}<LISPCORE>LIBRARY>FTPSERVER.;8 19301
changes to: (FNS \SFTP.RETRIEVE \SFTP.OPENFILE.FROM.PLIST \SFTP.PLIST.FROM.FILE \SFTP.STORE
\SFTP.ENUMERATE FTPSERVER \SFTP.WHENCLOSED \FTPSERVER.TOP START.FTPSERVER
\GETFILETYPE)
(VARS FTPSERVERCOMS)
previous date: "16-Oct-84 17:12:00" {ERIS}<LISPCORE>LIBRARY>FTPSERVER.;6)
(* Copyright (c) 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FTPSERVERCOMS)
(RPAQQ FTPSERVERCOMS ((FNS \FTPSERVER.TOP FTPSERVER \GETFILETYPE \SFTP.COMMANDLOOP \SFTP.RETRIEVE
\SFTP.ENUMERATE \SFTP.STORE \SFTP.VERSION)
(FNS \SFTP.OPENFILE.FROM.PLIST \SFTP.PLIST.FROM.FILE \SFTP.SENDPLIST
\SFTP.PROTOCOL.ERROR \SFTP.MARK.ERROR \SFTP.READPLIST \SFTP.TIMEOUTFN
\SFTP.ERRORHANDLER \SFTP.WHENCLOSED)
[E (PRINT (LIST (QUOTE RPAQQ)
(QUOTE \SFTP.VERSION)
(DATE]
[INITVARS (FTPSERVER.DEFAULT.HOST (QUOTE DSK))
(FTPSERVER.DEFAULT.PROPS (QUOTE (TYPE CREATIONDATE WRITEDATE READDATE
LENGTH AUTHOR]
(DECLARE: DONTCOPY (MACROS .IFDESIRED.)
(FILES (LOADCOMP)
DPUPFTP))))
(DEFINEQ
(\FTPSERVER.TOP
[LAMBDA (FTPDEBUGLOG) (* bvm: "16-Nov-84 11:46")
(PROG (PUPSOC SOCKET INSTREAM EVENT SAVER)
(COND
(FTPDEBUGLOG [COND
((OR (EQ FTPDEBUGLOG T)
(LISTP FTPDEBUGLOG))
(SETQ FTPDEBUGLOG (GETSTREAM (CREATEW (LISTP FTPDEBUGLOG)
"FTP Server traffic")
(QUOTE OUTPUT)))
(WINDOWPROP FTPDEBUGLOG (QUOTE PAGEFULLFN)
(FUNCTION NILL))
(DSPSCROLL (QUOTE ON)
FTPDEBUGLOG)
(DSPFONT (QUOTE (GACHA 8))
FTPDEBUGLOG))
(T (SETQ FTPDEBUGLOG (GETSTREAM FTPDEBUGLOG (QUOTE OUTPUT]
(printout FTPDEBUGLOG "FTP Server started at " (DATE)
T T)))
(RESETSAVE NIL (SETQ SAVER (LIST [FUNCTION (LAMBDA (SOC)
(AND SOC (CLOSERTPSOCKET SOC 0]
NIL)))
TOP (SETQ SOCKET (OPENRTPSOCKET NIL (QUOTE (SERVER RETURN))
(OPENPUPSOCKET \PUPSOCKET.FTP 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)))
(NLSETQ (RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEBSPSTREAM)
INSTREAM 0))
(RPLACA (CDR SAVER)
NIL)
(COND
(FTPDEBUGLOG (printout FTPDEBUGLOG T "Connection open with "
(PORTSTRING (fetch FRNPORT of SOCKET)
(\MAKENUMBER (fetch FRNSOCKETHI
of SOCKET)
(fetch FRNSOCKETLO
of SOCKET)))
T)
(RESETSAVE FTPDEBUGFLG T)))
(\SFTP.COMMANDLOOP INSTREAM (BSPOUTPUTSTREAM INSTREAM)
FTPDEBUGLOG]
(GO TOP])
(FTPSERVER
[LAMBDA (FTPDEBUGLOG) (* bvm: "16-Nov-84 10:52")
(ADD.PROCESS (LIST (FUNCTION \FTPSERVER.TOP)
(KWOTE FTPDEBUGLOG))
(QUOTE NAME)
(QUOTE FTPSERVER)
(QUOTE RESTARTABLE)
(QUOTE HARDRESET])
(\GETFILETYPE
[LAMBDA (FILE FILEOPENP) (* bvm: "16-Nov-84 11:57")
(RESETLST (PROG (STREAM)
[COND
[FILEOPENP (SETQ STREAM (GETSTREAM FILE (QUOTE INPUT]
(T (RESETSAVE NIL (LIST (QUOTE CLOSEF)
(SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT]
(RETURN (\INFER.FILE.TYPE STREAM])
(\SFTP.COMMANDLOOP
[LAMBDA (INS OUTS FTPDEBUGLOG)
(DECLARE (SPECVARS FTPDEBUGLOG)) (* bvm: "29-Feb-84 12:53")
(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.RETRIEVE
[LAMBDA (INS OUTS) (* bvm: "16-Nov-84 16:08")
(* Do the RETRIEVE command. Plist comes next)
(RESETLST (PROG (PLIST FILE)
(SETQ PLIST (OR (\SFTP.READPLIST INS OUTS)
(RETURN)))
(OR (EQ (FTPGETMARK INS)
(MARK# EOC))
(RETURN (\SFTP.PROTOCOL.ERROR INS OUTS)))
(SETQ FILE (OR (\SFTP.OPENFILE.FROM.PLIST PLIST (QUOTE INPUT)
OUTS)
(RETURN T)))
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
FILE))
(\SFTP.SENDPLIST (\SFTP.PLIST.FROM.FILE FILE NIL (for PAIR in PLIST
when (EQ (CAR PAIR)
(QUOTE
DESIRED-PROPERTY))
collect (CADR PAIR))
T)
OUTS)
(SELECTC (FTPGETMARK INS)
((MARK# NO) (* no, user doesn't want file)
(\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG))
((MARK# YES)
(FTPGETCODE INS)
(\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG)
(FTPPUTMARK OUTS (MARK# HERE-IS-FILE))
(COPYBYTES FILE OUTS)
(FTPPUTMARK OUTS (MARK# YES))
(FTPPUTCODE OUTS 0)
(PRIN3 "File sent ok" OUTS))
(RETURN (\SFTP.PROTOCOL.ERROR INS OUTS)))
(* At this point we would normally advance to the next
file, but we're not doing *'s yet)
(.EOC. OUTS)
(RETURN T])
(\SFTP.ENUMERATE
[LAMBDA (INS OUTS NEWP) (* bvm: "16-Nov-84 10:33")
(* Do the ENUMERATE command.
Plist comes next)
(PROG (PLIST FILE DESIREDPROPS GENERATOR PATTERN SCRATCH FOUNDSOME)
(SETQ PLIST (OR (\SFTP.READPLIST INS OUTS)
(RETURN)))
(OR (EQ (FTPGETMARK INS)
(MARK# EOC))
(RETURN (\SFTP.PROTOCOL.ERROR INS OUTS)))
[SETQ DESIREDPROPS (for PAIR in PLIST when (EQ (CAR PAIR)
(QUOTE DESIRED-PROPERTY))
collect (MKATOM (CADR PAIR]
(SETQ GENERATOR (OR (\SFTP.OPENFILE.FROM.PLIST PLIST (QUOTE ENUMERATE)
OUTS
(OR DESIREDPROPS FTPSERVER.DEFAULT.PROPS))
(RETURN T)))
(SETQ PATTERN (DIRECTORY.MATCH.SETUP (CAR GENERATOR)))
(SETQ GENERATOR (CDR GENERATOR))
(SETQ SCRATCH (from 1 to 127 collect NIL))
LP (COND
((SETQ FILE (\GENERATENEXTFILE GENERATOR NIL SCRATCH))
[COND
((COND
[(LISTP FILE) (* Argh, awful kludge that I have to filter it.
Fix this when enumeration in general is fixed)
(DIRECTORY.MATCH PATTERN (SETQ FILE (CONCATCODES FILE]
(T T))
[COND
((OR (NOT NEWP)
(NOT FOUNDSOME))
(FTPPUTMARK OUTS (MARK# HERE-IS-PLIST]
(SETQ FOUNDSOME T)
(\FTP.PRINTPLIST OUTS (\SFTP.PLIST.FROM.FILE (MKATOM FILE)
NIL DESIREDPROPS NIL GENERATOR]
(GO LP))
((NULL FOUNDSOME)
(FTPPUTMARK OUTS (MARK# NO))
(FTPPUTCODE OUTS \NO.FILE.NOT.FOUND T)
(PRIN3 "File not found" OUTS)))
(.EOC. OUTS)
(RETURN T])
(\SFTP.STORE
[LAMBDA (INS OUTS OLDSTYLE) (* bvm: "16-Nov-84 16:06")
(* Do the STORE command. Plist comes next)
(RESETLST (PROG (PLIST FILE SUCCESS SAVER)
(SETQ PLIST (OR (\SFTP.READPLIST INS OUTS)
(RETURN)))
(OR (EQ (FTPGETMARK INS)
(MARK# EOC))
(RETURN (\SFTP.PROTOCOL.ERROR INS OUTS)))
(SETQ FILE (OR (\SFTP.OPENFILE.FROM.PLIST PLIST (QUOTE OUTPUT)
OUTS)
(RETURN T)))
(RESETSAVE NIL (SETQ SAVER (LIST [FUNCTION (LAMBDA (STREAM)
(DELFILE (CLOSEF STREAM]
FILE)))
(COND
(OLDSTYLE (FTPPUTMARK OUTS (MARK# YES))
(FTPPUTCODE OUTS 0)
(.EOC. OUTS))
(T (\SFTP.SENDPLIST (\SFTP.PLIST.FROM.FILE FILE T (for PAIR in PLIST
when (EQ (CAR PAIR)
(QUOTE
DESIRED-PROPERTY))
collect (CADR PAIR))
T)
OUTS)))
(SELECTC (FTPGETMARK INS)
((MARK# NO) (* no, user doesn't want file)
(FTPGETCODE INS T)
(\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG))
((MARK# HERE-IS-FILE)
(SETQ SUCCESS (OR (NLSETQ (COPYBYTES INS FILE))
(PROGN (\FTP.FLUSH.TO.MARK INS)
NIL)))
(SELECTC (FTPGETMARK INS)
[(MARK# YES)
(FTPGETCODE INS)
(\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG)
(COND
((NULL SUCCESS)
(\SFTP.MARK.ERROR OUTS))
(T (FTPPUTMARK OUTS (MARK# YES))
(FTPPUTCODE OUTS 0)
(PRIN3 "File stored ok" OUTS)
(CLOSEF FILE)
(RPLACA SAVER (FUNCTION NILL]
((MARK# NO) (* Store failed)
(FTPGETCODE INS T)
(\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG))
(\SFTP.PROTOCOL.ERROR INS OUTS)))
(\SFTP.PROTOCOL.ERROR INS OUTS))
(.EOC. OUTS)
(RETURN T])
(\SFTP.VERSION
[LAMBDA (INS OUTS) (* bvm: "19-AUG-83 22:33")
(\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG)
(FTPPUTMARK OUTS (MARK# VERSION))
(FTPPUTCODE OUTS \FTP.VERSION)
(PRIN3 "Interlisp-D Ftp Server of " OUTS)
(PRIN3 \SFTP.VERSION OUTS)
(.EOC. OUTS])
)
(DEFINEQ
(\SFTP.OPENFILE.FROM.PLIST
[LAMBDA (PLIST ACCESS OUTS DESIREDPROPS) (* bvm: "16-Nov-84 12:31")
(* 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 (QUOTE HOST)
(COND
((EQ (NTHCHARCODE (CADR PAIR)
-1)
(CHARCODE :))
(SUBSTRING (CADR PAIR)
1 -2))
(T (CADR PAIR]
(DIRECTORY (push PIECES (QUOTE DIRECTORY)
(CADR PAIR)))
(NAME-BODY (push PIECES (QUOTE BODY)
(CADR PAIR)))
(VERSION (push PIECES (QUOTE VERSION)
(CADR PAIR)))
[TYPE (push MYPLIST (LIST (QUOTE TYPE)
(MKATOM (U-CASE (CADR PAIR]
[CREATION-DATE (push MYPLIST (LIST (QUOTE CREATIONDATE)
(CADR PAIR]
[END-OF-LINE-CONVENTION (push MYPLIST
(LIST (QUOTE EOLCONVENTION)
(U-CASE (CADR PAIR]
[SIZE (push MYPLIST (LIST (QUOTE LENGTH)
(MKATOM (CADR PAIR]
NIL))
(SETQ FILENAME (COND
[(NULL FILENAME)
(PACKFILENAME (NCONC PIECES (LIST (QUOTE HOST)
FTPSERVER.DEFAULT.HOST]
((NULL (FILENAMEFIELD FILENAME (QUOTE HOST)))
(PACKFILENAME (QUOTE HOST)
FTPSERVER.DEFAULT.HOST
(QUOTE BODY)
FILENAME))
(T FILENAME)))
(RETURN (COND
([NLSETQ (SETQ FILE (COND
((EQ ACCESS (QUOTE ENUMERATE))
(SETQ FILENAME (DIRECTORY.FILL.PATTERN FILENAME))
(CONS FILENAME (\GENERATEFILES FILENAME DESIREDPROPS)))
(T (OPENSTREAM FILENAME ACCESS NIL NIL (CONS (QUOTE SEQUENTIAL)
MYPLIST]
FILE)
(T (\SFTP.MARK.ERROR OUTS)
(.EOC. OUTS)
NIL])
(\SFTP.PLIST.FROM.FILE
[LAMBDA (FILE NEW DESIREDPROPS FILEOPENP GENERATOR) (* bvm: "16-Nov-84 12:32")
(* 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 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 (QUOTE CR))
(AND DIR (.IFDESIRED. DIRECTORY DIR))
(AND HOST (.IFDESIRED. DEVICE HOST]
[COND
((NOT NEW)
(SETQ PLIST (NCONC PLIST [.IFDESIRED. TYPE (SETQ TYPE (OR (APPLY* INFOFN INFOHANDLE
(QUOTE TYPE))
(\GETFILETYPE FILE FILEOPENP]
(AND (EQ TYPE (QUOTE BINARY))
(LIST (LIST (QUOTE BYTE-SIZE)
8)))
(.IFDESIRED. CREATION-DATE (APPLY* INFOFN INFOHANDLE (QUOTE
CREATIONDATE)))
(.IFDESIRED. WRITE-DATE (APPLY* INFOFN INFOHANDLE (QUOTE WRITEDATE)))
(.IFDESIRED. READ-DATE (APPLY* INFOFN INFOHANDLE (QUOTE READDATE)))
(.IFDESIRED. SIZE (APPLY* INFOFN INFOHANDLE (QUOTE LENGTH)))
(.IFDESIRED. AUTHOR (APPLY* INFOFN INFOHANDLE (QUOTE AUTHOR]
(RETURN PLIST])
(\SFTP.SENDPLIST
[LAMBDA (PLIST OUTS) (* bvm: "20-AUG-83 00:07")
(FTPPUTMARK OUTS (MARK# HERE-IS-PLIST))
(\FTP.PRINTPLIST OUTS PLIST)
(.EOC. OUTS])
(\SFTP.PROTOCOL.ERROR
[LAMBDA (INS OUTS) (* bvm: "19-AUG-83 18:14")
(FTPPUTMARK OUTS (MARK# NO))
(FTPPUTCODE OUTS \NO.PROTOCOL.ERROR)
(PRIN3 "Protocol Error - Aborting connection" OUTS)
(CLOSEBSPSTREAM INS 0)
NIL])
(\SFTP.MARK.ERROR
[LAMBDA (OUTS) (* bvm: "29-Feb-84 13:50")
(* Put out a NO mark followed by appropriate error code
and message for last error. Caller supplies EOC)
(PROG ((ERN (ERRORN)))
(FTPPUTMARK OUTS (MARK# NO))
(FTPPUTCODE OUTS (SELECTQ (CAR ERN)
(5 \NO.DISK.ERROR)
(9 \NO.FILE.PROTECTED)
(22 \NO.STORAGE.FULL)
(23 \NO.FILE.NOT.FOUND)
\NO.FILE.PROTECTED))
(PRIN3 (CONCAT (ERRORSTRING (CAR ERN))
": "
(CADR ERN))
OUTS])
(\SFTP.READPLIST
[LAMBDA (INS OUTS) (* bvm: "20-AUG-83 18:47")
(* Read plist from user, return NIL, aborting
connection, on error)
(PROG [(PLIST (NLSETQ (READPLIST INS]
(RETURN (COND
((NULL PLIST)
(\SFTP.PROTOCOL.ERROR INS OUTS))
(T (COND
(FTPDEBUGFLG (PRIN2 (CAR PLIST)
FTPDEBUGLOG)))
(CAR PLIST])
(\SFTP.TIMEOUTFN
[LAMBDA (STREAM) (* bvm: "20-AUG-83 17:45")
(COND
((BSPOPENP STREAM (QUOTE INPUT))
(replace IOTIMEOUTFN of (fetch BSPSOC of STREAM) with NIL)
(CLOSEBSPSTREAM STREAM])
(\SFTP.ERRORHANDLER
[LAMBDA (INSTREAM ERRCODE) (* bvm: "20-AUG-83 00:31")
(SELECTQ ERRCODE
(MARK.ENCOUNTERED (COND
((fetch FTPOPENP of INSTREAM)
(STREAMOP (QUOTE ENDOFSTREAMOP)
INSTREAM INSTREAM))
(T -1)))
(ERROR!])
(\SFTP.WHENCLOSED
[LAMBDA (STREAM) (* bvm: "16-Nov-84 10:31")
(AND (FIND.PROCESS (QUOTE FTPSERVER))
(PROCESS.EVAL (QUOTE FTPSERVER)
(QUOTE (PROGN (AND FTPDEBUGLOG (printout FTPDEBUGLOG T "Connection closed" T)
(RESET])
)
(RPAQQ \SFTP.VERSION "16-Nov-84 16:12:47")
(RPAQ? FTPSERVER.DEFAULT.HOST (QUOTE DSK))
(RPAQ? FTPSERVER.DEFAULT.PROPS (QUOTE (TYPE CREATIONDATE WRITEDATE READDATE LENGTH AUTHOR)))
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS .IFDESIRED. MACRO [(PROP . LISTFORM)
(AND (OR (NULL DESIREDPROPS)
(FMEMB (QUOTE PROP)
DESIREDPROPS))
(PROG ((PROPVAL . LISTFORM))
(RETURN (AND PROPVAL (LIST (LIST (QUOTE PROP)
PROPVAL])
)
(FILESLOAD (LOADCOMP)
DPUPFTP)
)
(PUTPROPS FTPSERVER COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1184 11401 (\FTPSERVER.TOP 1194 . 3369) (FTPSERVER 3371 . 3670) (\GETFILETYPE 3672 .
4083) (\SFTP.COMMANDLOOP 4085 . 5298) (\SFTP.RETRIEVE 5300 . 6957) (\SFTP.ENUMERATE 6959 . 8912) (
\SFTP.STORE 8914 . 11079) (\SFTP.VERSION 11081 . 11399)) (11402 18642 (\SFTP.OPENFILE.FROM.PLIST 11412
. 13639) (\SFTP.PLIST.FROM.FILE 13641 . 16092) (\SFTP.SENDPLIST 16094 . 16301) (\SFTP.PROTOCOL.ERROR
16303 . 16587) (\SFTP.MARK.ERROR 16589 . 17234) (\SFTP.READPLIST 17236 . 17727) (\SFTP.TIMEOUTFN 17729
. 17996) (\SFTP.ERRORHANDLER 17998 . 18306) (\SFTP.WHENCLOSED 18308 . 18640)))))
STOP