(FILECREATED "29-Feb-84 13:51:28" {PHYLUM}<LISPCORE>LIBRARY>FTPSERVER.;1 16726
changes to: (FNS \SFTP.STORE \SFTP.COMMANDLOOP \SFTP.OPENFILE.FROM.PLIST \SFTP.MARK.ERROR)
(VARS \SFTP.DEFAULT.HOST)
previous date: "10-OCT-83 02:44:33" {PHYLUM}<LISP>LIBRARY>FTPSERVER.;2)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT FTPSERVERCOMS)
(RPAQQ FTPSERVERCOMS ((FNS \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]
(VARS \SFTP.DEFAULT.HOST)
(MACROS .IFDESIRED.)))
(DEFINEQ
(\FTPSERVER
[LAMBDA (FTPDEBUGLOG) (* lmm "10-OCT-83 02:41")
(PROG (PUPSOC SOCKET INSTREAM EVENT SAVER)
[COND
(FTPDEBUGLOG (SETQ FTPDEBUGLOG (GETSTREAM FTPDEBUGLOG (QUOTE OUTPUT)))
(COND
((DISPLAYSTREAMP FTPDEBUGLOG)
(WINDOWPROP FTPDEBUGLOG (QUOTE PAGEFULLFN)
(FUNCTION NILL))
(DSPSCROLL (QUOTE ON)
FTPDEBUGLOG)
(DSPFONT (QUOTE (GACHA 8))
FTPDEBUGLOG]
(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 STATE 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])
(\GETFILETYPE
[LAMBDA (FILE FILEOPENP) (* bvm: "20-AUG-83 17:17")
(PROG [(TYPE (GETFILEINFO FILE (QUOTE TYPE]
(RETURN (OR TYPE (RESETLST (PROG (STREAM)
[COND
(FILEOPENP (RESETSAVE NIL
(LIST (FUNCTION [LAMBDA (STREAM
EOS)
(replace ENDOFSTREAMOP
of STREAM
with EOS])
(SETQ STREAM
(GETSTREAM FILE
(QUOTE INPUT)))
(fetch ENDOFSTREAMOP
of STREAM)))
(RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
STREAM
(GETFILEPTR STREAM)))
(SETFILEPTR STREAM 0))
(T (RESETSAVE NIL (LIST (QUOTE CLOSEF)
(SETQ STREAM
(OPENSTREAM FILE (QUOTE INPUT]
(replace ENDOFSTREAMOP of STREAM
with (FUNCTION NILL))
(RETURN (do (COND
((IGREATERP (OR (BIN STREAM)
(RETURN (QUOTE TEXT)))
127)
(RETURN (QUOTE BINARY])
(\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: "20-AUG-83 17:21")
(* Do the RETRIEVE command. Plist comes next)
(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)))
(\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)))
(CLOSEF FILE) (* 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: "20-AUG-83 18:53")
(* 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 GENERATOR (OR (\SFTP.OPENFILE.FROM.PLIST PLIST (QUOTE ENUMERATE)
OUTS)
(RETURN T)))
(SETQ DESIREDPROPS (for PAIR in PLIST when (EQ (CAR PAIR)
(QUOTE DESIRED-PROPERTY))
collect (CADR PAIR)))
[SETQ PATTERN (CHCON (U-CASE (MKSTRING (CAR GENERATOR]
(SETQ GENERATOR (CDR GENERATOR))
(SETQ SCRATCH (from 1 to 127 collect NIL))
LP (COND
((SETQ FILE (\GENERATENEXTFILE GENERATOR SCRATCH NIL T))
[COND
((DMATCH PATTERN FILE) (* Argh, awful kludge that I have to filter it.
Fix this when enumeration in general is fixed)
[COND
((OR (NOT NEWP)
(NOT FOUNDSOME))
(FTPPUTMARK OUTS (MARK# HERE-IS-PLIST]
(SETQ FOUNDSOME T)
(\FTP.PRINTPLIST OUTS (\SFTP.PLIST.FROM.FILE (PACKC FILE)
NIL DESIREDPROPS]
(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: "29-Feb-84 12:52")
(* Do the STORE command. Plist comes next)
(PROG (PLIST FILE SUCCESS)
(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)))
(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)
(.EOC. OUTS)
(RETURN T]
((MARK# NO) (* Store failed)
(FTPGETCODE INS T)
(\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG))
(\SFTP.PROTOCOL.ERROR INS OUTS)))
(\SFTP.PROTOCOL.ERROR INS OUTS))
(DELFILE (CLOSEF FILE))
(.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) (* bvm: "29-Feb-84 13:41")
(* 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)
(U-CASE (CADR PAIR]
[CREATION-DATE (push MYPLIST (LIST (QUOTE CREATIONDATE)
(CONCATLIST (CDR PAIR]
[END-OF-LINE-CONVENTION (push MYPLIST
(LIST (QUOTE EOLCONVENTION)
(U-CASE (CADR PAIR]
[SIZE (push MYPLIST (LIST (QUOTE LENGTH)
(CADR PAIR]
NIL))
(SETQ FILENAME (COND
[(NULL FILENAME)
(PACKFILENAME (NCONC PIECES (LIST (QUOTE HOST)
\SFTP.DEFAULT.HOST]
((NULL (FILENAMEFIELD FILENAME (QUOTE HOST)))
(PACKFILENAME (QUOTE HOST)
\SFTP.DEFAULT.HOST
(QUOTE BODY)
FILENAME))
(T FILENAME)))
(RETURN (COND
([NLSETQ (SETQ FILE (COND
((EQ ACCESS (QUOTE ENUMERATE))
(CONS FILENAME (\GENERATEFILES FILENAME)))
(T (OPENFILE 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) (* bvm: "20-AUG-83 19:07")
(* Generates a PLIST from FILE.
NEW is true if file is being written anew DESIREDPROPS
may restrict what we send)
(PROG ((PIECES (UNPACKFILENAME FILE))
HOST DIR NAME EXT VERSION AUTHOR TYPE PLIST)
(for TAIL on PIECES by (CDDR TAIL) do (SELECTQ (CAR TAIL)
[HOST (COND
((EQ (CADR TAIL)
\SFTP.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 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 (\GETFILETYPE FILE FILEOPENP)))
(AND (EQ TYPE (QUOTE BINARY))
(LIST (LIST (QUOTE BYTE-SIZE)
8)))
(.IFDESIRED. CREATION-DATE (GETFILEINFO FILE (QUOTE CREATIONDATE)))
(.IFDESIRED. WRITE-DATE (GETFILEINFO FILE (QUOTE WRITEDATE)))
(.IFDESIRED. READ-DATE (GETFILEINFO FILE (QUOTE READDATE)))
(.IFDESIRED. SIZE (GETFILEINFO FILE (QUOTE LENGTH)))
(.IFDESIRED. AUTHOR (GETFILEINFO FILE (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: "19-AUG-83 23:13")
(AND (FIND.PROCESS (QUOTE \FTPSERVER))
(PROCESS.EVAL (QUOTE \FTPSERVER)
(QUOTE (PROGN (AND FTPDEBUGLOG (PRINTOUT FTPDEBUGLOG T "Connection closed" T)
(RESET])
)
(RPAQQ \SFTP.VERSION "29-Feb-84 13:52:00")
(RPAQQ \SFTP.DEFAULT.HOST DSK)
(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])
)
(PUTPROPS FTPSERVER COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (867 10107 (\FTPSERVER 877 . 2592) (\GETFILETYPE 2594 . 3669) (\SFTP.COMMANDLOOP 3671 .
4884) (\SFTP.RETRIEVE 4886 . 6341) (\SFTP.ENUMERATE 6343 . 7934) (\SFTP.STORE 7936 . 9785) (
\SFTP.VERSION 9787 . 10105)) (10108 16279 (\SFTP.OPENFILE.FROM.PLIST 10118 . 12002) (
\SFTP.PLIST.FROM.FILE 12004 . 13763) (\SFTP.SENDPLIST 13765 . 13972) (\SFTP.PROTOCOL.ERROR 13974 .
14258) (\SFTP.MARK.ERROR 14260 . 14905) (\SFTP.READPLIST 14907 . 15398) (\SFTP.TIMEOUTFN 15400 . 15667
) (\SFTP.ERRORHANDLER 15669 . 15977) (\SFTP.WHENCLOSED 15979 . 16277)))))
STOP