(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 9-Sep-88 19:06:08" {DSK}MEDLEY-SOURCES>FTPSERVERPATCH.;4 18581 changes to%: (FNS \SFTP.OPENFILE.FROM.PLIST) (MACROS .IFDESIRED.) previous date%: " 7-Sep-88 16:59:13" {DSK}MEDLEY-SOURCES>FTPSERVERPATCH.;2) (* " Copyright (c) 1987, 1988 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 7-Sep-88 16:50 by Matt Heffron") (LET ((*UPPER-CASE-FILE-NAMES* NIL) MARK) (DECLARE (SPECVARS *UPPER-CASE-FILE-NAMES*)) (* ;  "We certainly don't need anything to be upper-case symbols.") (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# DELETE) (\SFTP.DELETE 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 (* ; "timed out") 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 RECOG) (* ; "Edited 9-Sep-88 19:04 by Matt Heffron") (* ;  "Opens file from user's PLIST, or answers NO and returns NIL") (LET (FILENAME PIECES MYPLIST VALUE HIGHESTVERSIONP) (for PAIR in PLIST do (SETQ VALUE (CADR PAIR)) (SELECTQ (CAR PAIR) (SERVER-FILENAME (SETQ PIECES (UNPACKFILENAME.STRING VALUE))) ((DEVICE DIRECTORY VERSION) (push PIECES (CAR PAIR) VALUE)) (NAME-BODY (push PIECES 'BODY VALUE)) (TYPE [push MYPLIST (LIST 'TYPE (MKATOM (U-CASE VALUE]) ((CREATION-DATE CREATIONDATE) (push MYPLIST (LIST 'CREATIONDATE VALUE))) ((END-OF-LINE-CONVENTION EOLCONVENTION EOC) [push MYPLIST (LIST 'EOLCONVENTION (MKATOM (U-CASE VALUE]) (SIZE (push MYPLIST (LIST 'LENGTH (MKATOM VALUE)))) NIL)) (for TAIL on PIECES by (CDDR TAIL) do (* ;  "Process some parts. Done here rather than above so that SERVER-FILENAME works easily.") (SELECTQ (CAR TAIL) (DEVICE (* ; "Fake host") (RPLACA TAIL 'HOST) [COND ((EQ (NTHCHARCODE (CADR TAIL) -1) (CHARCODE %:)) (* ;  "Device specified with trailing colon--strip it") (RPLACA (CDR TAIL) (SUBSTRING (CADR TAIL) 1 -2]) (VERSION [if (if (STRING.EQUAL (SETQ VALUE (CADR TAIL)) "H") then (SETQ RECOG 'OLD) (SETQ HIGHESTVERSIONP T) elseif (STRING.EQUAL VALUE "L") then (SETQ RECOG 'OLDEST)) then (* ; "Remove VERSION attribute.") (if (EQ TAIL PIECES) then (SETQ PIECES (CDDR TAIL)) else (RPLACD (NLEFT PIECES 1 TAIL) (CDDR TAIL]) NIL)) [SETQ FILENAME (PACKFILENAME.STRING `(,.PIECES HOST ,FTPSERVER.DEFAULT.HOST ,@(if (EQ ACCESS 'ENUMERATE) then (* ;  "Need to default extension to * before possibly packing on a version.") '(EXTENSION *] (CL:MULTIPLE-VALUE-BIND (RESULT C) [IGNORE-ERRORS (SELECTQ ACCESS (ENUMERATE (SETQ FILENAME (DIRECTORY.FILL.PATTERN FILENAME NIL (if HIGHESTVERSIONP then "" else "*"))) [CONS FILENAME (\GENERATEFILES FILENAME DESIREDPROPS '(RESETLST SORT)]) (DELETE (FULLNAME FILENAME RECOG)) (OPENSTREAM FILENAME ACCESS RECOG NIL (CONS '(SEQUENTIAL T) MYPLIST] (COND (RESULT) (T (* ; "On failure, write error value and return NIL. C could be NIL if FULLNAME didn't find the file, in which case the error will be FILE NOT FOUND.") (\SFTP.MARK.ERROR OUTS C) (.EOC. OUTS) NIL]) (\SFTP.PLIST.FROM.FILE [LAMBDA (FILE NEW DESIREDPROPS FILEOPENP GENERATOR) (* ; "Edited 7-Sep-88 16:40 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 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 ((STRING-EQUAL (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 PLIST (NCONC PLIST [.IFDESIRED. TYPE (SETQ TYPE (OR (CL:FUNCALL INFOFN INFOHANDLE 'TYPE) (\GETFILETYPE FILE FILEOPENP] (AND (EQ TYPE 'BINARY) (LIST (LIST 'BYTE-SIZE 8))) (.IFDESIRED. CREATION-DATE (CL:FUNCALL INFOFN INFOHANDLE 'CREATIONDATE)) (.IFDESIRED. WRITE-DATE (CL:FUNCALL INFOFN INFOHANDLE 'WRITEDATE)) (.IFDESIRED. READ-DATE (CL:FUNCALL INFOFN INFOHANDLE 'READDATE)) (.IFDESIRED. SIZE (CL:FUNCALL INFOFN INFOHANDLE 'LENGTH)) (.IFDESIRED. AUTHOR (CL:FUNCALL INFOFN INFOHANDLE 'AUTHOR] (RETURN PLIST]) (\SFTP.WHENCLOSED [LAMBDA (STREAM) (DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 7-Sep-88 16:51 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 (* ; "Was: (DEL.PROCESS SERVERPROC)") (PROCESS.EVAL SERVERPROC '(ERROR!]) ) (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 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1262 17784 (FTPSERVER 1272 . 1807) (NEGOTIATED-FTPSERVER 1809 . 2215) (\FTPSERVER.TOP 2217 . 3577) (\NEGOTIATED-FTPSERVER.TOP 3579 . 6442) (\SFTP.COMMANDLOOP 6444 . 8761) ( \SFTP.OPENFILE.FROM.PLIST 8763 . 14134) (\SFTP.PLIST.FROM.FILE 14136 . 17215) (\SFTP.WHENCLOSED 17217 . 17782))))) STOP