(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-May-87 18:06:12" {ERIS}<LISPCORE>PATCHES>RELEASE>TCPFTPSRV.;1 52825
changes to%: (FNS TCPFTP.SERVER.PARSE.PORT)
previous date%: " 2-Apr-87 12:32:33" {ERINYES}<LYRIC>LIBRARY>TCPFTPSRV.;3)
(* "
Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT TCPFTPSRVCOMS)
(RPAQQ TCPFTPSRVCOMS
((FNS TCPFTP.SERVER TCPFTP.SERVER.ABORTED TCPFTP.SERVER.ACCOUNT TCPFTP.SERVER.APPEND
TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTP.SERVER.COMMAND.LOOP
TCPFTP.SERVER.CONNECTED.INFO TCPFTP.SERVER.DELETE TCPFTP.SERVER.DIRECTORY
TCPFTP.SERVER.EXIT TCPFTP.SERVER.IDLE.INFO TCPFTP.SERVER.LIST
TCPFTP.SERVER.MERGE.PATHNAMES TCPFTP.SERVER.MODE TCPFTP.SERVER.OPEN.DATA.CONNECTION
TCPFTP.SERVER.PARSE.PORT TCPFTP.SERVER.PASSWORD TCPFTP.SERVER.PATH TCPFTP.SERVER.PORT
TCPFTP.SERVER.RENAME.FROM TCPFTP.SERVER.RENAME.TO TCPFTP.SERVER.RESPONSE
TCPFTP.SERVER.RETRIEVE TCPFTP.SERVER.STORE TCPFTP.SERVER.STRUCTURE TCPFTP.SERVER.TYPE
TCPFTP.SERVER.USER TCPFTP.SERVER.VERBOSE.LIST TCPFTP.SERVER.WAIT.FOR.IDLE
TCPFTP.UNIX.LS.DATE)
(INITVARS (TCPFTP.SERVER.HERALD.STRING "Xerox Lisp FTP Service 0.9 at your service")
(TCPFTP.SERVER.USE.TOPS20.SYNTAX T)
(TCPFTP.SERVER.RETRYCOUNT 5))
(GLOBALVARS TCPFTP.SERVER.HERALD.STRING TCPFTP.SERVER.USE.TOPS20.SYNTAX
TCPFTP.SERVER.RETRYCOUNT)
(FILES (SYSLOAD)
TCPFTP)))
(DEFINEQ
(TCPFTP.SERVER
[LAMBDA (PORT DEFAULT.FILE.PATH) (* ejs%: "24-Mar-86 15:18")
(* * This is the TCP-based FTP server top-level)
(PROCESSPROP (THIS.PROCESS)
'INFOHOOK
(FUNCTION TCPFTP.SERVER.IDLE.INFO))
(LET* ((CONTROL.INPUT.STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.FTP.PORT)
'PASSIVE
'INPUT))
(CONTROL.OUTPUT.STREAM (TCP.OTHER.STREAM CONTROL.INPUT.STREAM)))
(* EOL convention -> TELNET Standard)
(SETFILEINFO CONTROL.OUTPUT.STREAM 'EOL 'CRLF) (* Say hello quickly)
(TCPFTP.SERVER.RESPONSE 220 TCPFTP.SERVER.HERALD.STRING CONTROL.OUTPUT.STREAM)
(* Spawn a new server)
(ADD.PROCESS (LIST (FUNCTION TCPFTP.SERVER)
PORT
(KWOTE DEFAULT.FILE.PATH))
'RESTARTABLE
'HARDRESET) (* Now that we're "established,"
errors are fatal)
(PROCESSPROP (THIS.PROCESS)
'RESTARTABLE
'NO)
(PROCESSPROP (THIS.PROCESS)
'INFOHOOK
(FUNCTION TCPFTP.SERVER.CONNECTED.INFO))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM)
(COND
(RESETSTATE (TCPFTP.SERVER.ABORTED CONTROL.INPUT.STREAM
CONTROL.OUTPUT.STREAM))
(T (TCPFTP.SERVER.EXIT CONTROL.INPUT.STREAM
CONTROL.OUTPUT.STREAM]
CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM))
(TCPFTP.SERVER.COMMAND.LOOP CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM DEFAULT.FILE.PATH])
(TCPFTP.SERVER.ABORTED
[LAMBDA (INSTREAM OUTSTREAM) (* ejs%: "20-Mar-86 19:53")
(TCPFTP.SERVER.EXIT INSTREAM OUTSTREAM])
(TCPFTP.SERVER.ACCOUNT
[LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 11:40")
(* * This function parses USER commands)
(LET ((ACCT (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL)))
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG ACCT T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(TCPFTP.SERVER.RESPONSE 230 "You sure are formal!" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.APPEND
[LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH) (* ejs%: "24-Mar-86 14:07")
(* * This function parses USER commands)
(LET*
[(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
(TRUENAME (CAR (NLSETQ (OR (INFILEP PACKED.FILENAME)
(OUTFILEP PACKED.FILENAME]
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(COND
[TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'APPEND NIL
`((TYPE %, TYPE]
(COND
[FILESTREAM
(TCPFTP.SERVER.RESPONSE 150 (CONCAT
"Opening data connection for append to "
(FULLNAME FILESTREAM))
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
(LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT T
)))
(COND
(DATASTREAM [replace (STREAM ENDOFSTREAMOP) of DATASTREAM
with (FUNCTION (LAMBDA (STREAM)
(ERROR!]
(RESETLST (RESETSAVE (COND
((EQ TYPE 'BINARY)
(COPYBYTES DATASTREAM FILESTREAM))
(T (COPYCHARS DATASTREAM FILESTREAM
)))
(LIST [FUNCTION (LAMBDA (FILESTREAM
TCPFTPCON)
(CLOSEF? FILESTREAM)
(
TCPFTP.SERVER.CLOSE.DATA.CONNECTION
TCPFTPCON)
(TCPFTP.SERVER.RESPONSE
226
"Data transfer complete"
(fetch (TCPFTPCON
TCPOUT)
of TCPFTPCON]
FILESTREAM TCPFTPCON]
(T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
(T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "Unable to create output filename - " PACKED.FILENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.CLOSE.DATA.CONNECTION
[LAMBDA (TCPFTPCON) (* ejs%: "20-Mar-86 17:53")
(LET ((DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))
(EVENT (fetch (TCPFTPCON BUSY?) of TCPFTPCON)))
(CLOSEF? DATASTREAM)
(replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL)
(replace (TCPFTPCON BUSY?) of TCPFTPCON with NIL)
(NOTIFY.EVENT EVENT)
T])
(TCPFTP.SERVER.COMMAND.LOOP
[LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM PATH) (* ejs%: "26-Sep-86 17:45")
(DECLARE (SPECVARS TCPFTPCON COMMAND))
(LET ([COMMAND.RDTBL (DEFERREDCONSTANT (PROG [(R (COPYREADTABLE 'ORIG]
(SETBRK NIL NIL R)
(SETSYNTAX '%% 'OTHER R)
(SETSEPR '(13 10 31 32) NIL R)
(RETURN R]
(TCPFTPCON (create TCPFTPCON
TCPIN ← CONTROL.INPUT.STREAM
TCPOUT ← CONTROL.OUTPUT.STREAM))
(TYPE TCP.DEFAULTFILETYPE)
RENAME.FROM.FILE LAST.COMMAND USERPORT)
(OR PATH (SETQ PATH "{DSK}<LISPFILES>"))
(while (AND (OPENP CONTROL.INPUT.STREAM 'INPUT)
(OPENP CONTROL.OUTPUT.STREAM 'OUTPUT)
(NOT (EOFP CONTROL.INPUT.STREAM)))
first [PROCESSPROP (THIS.PROCESS)
'NAME
(CONCAT "FTP#" (\IP.ADDRESS.TO.STRING (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST
)
of (fetch (TCPSTREAM TCB)
of CONTROL.INPUT.STREAM]
do (LET [(COMMAND (U-CASE (CAR (NLSETQ (READ CONTROL.INPUT.STREAM COMMAND.RDTBL]
[COND
((AND (OPENP CONTROL.INPUT.STREAM 'INPUT)
(NOT (EOFP CONTROL.INPUT.STREAM)))
(COND
([NOT (FMEMB COMMAND '(QUIT REIN ABOR NOOP NIL]
(BIN CONTROL.INPUT.STREAM] (* Advance past the space preceding
the argument)
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG T "> " COMMAND " ")))
(SELECTQ COMMAND
(USER (TCPFTP.SERVER.USER TCPFTPCON COMMAND.RDTBL))
(PASS (TCPFTP.SERVER.PASSWORD TCPFTPCON COMMAND.RDTBL))
(ACCT (TCPFTP.SERVER.ACCOUNT TCPFTPCON COMMAND.RDTBL))
(CWD (SETQ PATH (OR (TCPFTP.SERVER.PATH TCPFTPCON COMMAND.RDTBL PATH)
PATH)))
(PORT (SETQ USERPORT (OR (TCPFTP.SERVER.PORT TCPFTPCON COMMAND.RDTBL)
USERPORT)))
(TYPE (SETQ TYPE (OR (TCPFTP.SERVER.TYPE TCPFTPCON COMMAND.RDTBL)
TYPE)))
(MODE (TCPFTP.SERVER.MODE TCPFTPCON COMMAND.RDTBL))
(STRU (TCPFTP.SERVER.STRUCTURE TCPFTPCON COMMAND.RDTBL))
(NLST (TCPFTP.SERVER.DIRECTORY TCPFTPCON COMMAND.RDTBL USERPORT PATH COMMAND))
(LIST (TCPFTP.SERVER.LIST TCPFTPCON COMMAND.RDTBL USERPORT PATH COMMAND))
(RETR (TCPFTP.SERVER.RETRIEVE TCPFTPCON COMMAND.RDTBL USERPORT TYPE PATH))
(STOR (TCPFTP.SERVER.STORE TCPFTPCON COMMAND.RDTBL USERPORT TYPE PATH))
(APPE (TCPFTP.SERVER.APPEND TCPFTPCON COMMAND.RDTBL USERPORT TYPE PATH))
(DELE (TCPFTP.SERVER.DELETE TCPFTPCON COMMAND.RDTBL PATH))
(RNFR (SETQ RENAME.FROM.FILE (TCPFTP.SERVER.RENAME.FROM TCPFTPCON
COMMAND.RDTBL PATH)))
(RNTO (COND
((EQ LAST.COMMAND 'RNFR)
(TCPFTP.SERVER.RENAME.TO TCPFTPCON COMMAND.RDTBL PATH
RENAME.FROM.FILE))
(T (TCPFTP.SERVER.RESPONSE 503
"I need a RNFR command immediately preceding a RNTO command."
CONTROL.OUTPUT.STREAM))))
(REIN (DISCARDLINE CONTROL.INPUT.STREAM)
(TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTPCON)
(TCPFTP.SERVER.RESPONSE 220 "Go ahead" CONTROL.OUTPUT.STREAM))
(QUIT (DISCARDLINE CONTROL.INPUT.STREAM)
(TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTPCON)
(TCPFTP.SERVER.RESPONSE 221 "It's been real" CONTROL.OUTPUT.STREAM)
(RETURN))
(NOOP (TCPFTP.SERVER.RESPONSE 200 "I'm still here" CONTROL.OUTPUT.STREAM))
(NIL (* Error reading from control stream)
(ERROR!))
(PROGN (DISCARDLINE CONTROL.INPUT.STREAM)
(TCPFTP.SERVER.RESPONSE 502 (CONCAT "Unrecognized command " COMMAND)
CONTROL.OUTPUT.STREAM)))
(SETQ LAST.COMMAND COMMAND])
(TCPFTP.SERVER.CONNECTED.INFO
[LAMBDA (PROCESS BUTTON) (* ejs%: "21-Mar-86 17:07")
[PROMPTPRINT "TCPFTP server connected to " (IPHOSTNAME (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST)
of (fetch (TCPSTREAM TCB) of
CONTROL.INPUT.STREAM
]
(COND
((EQ BUTTON 'MIDDLE)
(COND
((AND (BOUNDP 'TCPFTPCON)
(fetch (TCPFTPCON BUSY?) of TCPFTPCON))
(printout PROMPTWINDOW T " Server is busy; last command was "
(OR (AND (BOUNDP 'COMMAND)
COMMAND)
"???")))
((AND (BOUNDP COMMAND)
COMMAND)
(printout PROMPTWINDOW T " Last command was " COMMAND])
(TCPFTP.SERVER.DELETE
[LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH) (* ejs%: " 7-Apr-86 11:42")
(* * This function parses USER commands)
(LET* ((FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T T))
TRUENAME)
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(COND
[PACKED.FILENAME (COND
([SETQ TRUENAME (CAR (NLSETQ (DELFILE PACKED.FILENAME]
(TCPFTP.SERVER.RESPONSE 250
(CONCAT "Deleted " (COND
(TCPFTP.SERVER.USE.TOPS20.SYNTAX
(REPACKFILENAME.STRING
(PACKFILENAME.STRING 'HOST NIL
'BODY TRUENAME)
'TOPS-20))
(T TRUENAME)))
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
(T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't delete file "
TRUENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
(T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.DIRECTORY
[LAMBDA (TCPFTPCON RDTBL USERPORT DEFAULT.PATH COMMAND) (* edited%: "21-Mar-86 15:16")
(* * This function parses USER commands)
(LET* [(PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(FILES (CAR (NLSETQ (DIRECTORY (TCPFTP.SERVER.MERGE.PATHNAMES PATH DEFAULT.PATH T]
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG PATH T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for directory of " PATH " ["
(LENGTH FILES)
" file name(s)]")
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
(LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT)))
(COND
(DATASTREAM (for FILE in FILES
do (PRIN1 (COND
(TCPFTP.SERVER.USE.TOPS20.SYNTAX
(REPACKFILENAME.STRING (PACKFILENAME.STRING
'HOST NIL 'BODY FILE)
'TOPS-20))
(T FILE))
DATASTREAM)
(TERPRI DATASTREAM) finally (TCPFTP.SERVER.CLOSE.DATA.CONNECTION
TCPFTPCON))
(TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch (TCPFTPCON
TCPOUT)
of TCPFTPCON])
(TCPFTP.SERVER.EXIT
[LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM) (* ejs%: "20-Mar-86 19:52")
(CLOSEF? CONTROL.OUTPUT.STREAM)
(CLOSEF? CONTROL.INPUT.STREAM])
(TCPFTP.SERVER.IDLE.INFO
[LAMBDA (PROCESS BUTTON) (* ejs%: "21-Mar-86 16:58")
(PROMPTPRINT "Idle TCPFTP server"])
(TCPFTP.SERVER.LIST
[LAMBDA (TCPFTPCON RDTBL USERPORT DEFAULT.PATH COMMAND) (* edited%: "21-Mar-86 15:20")
(* * This function parses USER commands)
(LET* ((PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
[FILES (CAR (NLSETQ (DIRECTORY (TCPFTP.SERVER.MERGE.PATHNAMES PATH DEFAULT.PATH T]
(NFILES (LENGTH FILES)))
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG PATH T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for directory of " PATH " ["
NFILES " file name(s)]")
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
(LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT)))
(COND
(DATASTREAM (for FILE in FILES
do (COND
((EQ NFILES 1)
(LET [(FILESTREAM (OPENSTREAM FILE 'INPUT 'OLD]
(TCPFTP.SERVER.VERBOSE.LIST FILESTREAM DATASTREAM)
(CLOSEF FILESTREAM)))
(T (PRIN1 (COND
(TCPFTP.SERVER.USE.TOPS20.SYNTAX
(REPACKFILENAME.STRING (PACKFILENAME.STRING
'HOST NIL 'BODY FILE)
'TOPS-20))
(T FILE))
DATASTREAM)
(TERPRI DATASTREAM))) finally (
TCPFTP.SERVER.CLOSE.DATA.CONNECTION
TCPFTPCON))
(TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch (TCPFTPCON
TCPOUT)
of TCPFTPCON])
(TCPFTP.SERVER.MERGE.PATHNAMES
[LAMBDA (NAME DEFAULT.PATH NODEVICE.IF.LOCAL NOVERSION.IF.LOCAL)
(* ejs%: "26-Sep-86 17:40")
(LET* [[NAMEFIELDS (UNPACKFILENAME.STRING (REPACKFILENAME.STRING NAME 'INTERLISP]
(DEFAULTFIELDS (UNPACKFILENAME.STRING DEFAULT.PATH))
[HOST (OR (LISTGET NAMEFIELDS 'HOST)
(LISTGET DEFAULTFIELDS 'HOST]
(HOSTSPECIFIED (NOT (NULL (LISTGET NAMEFIELDS 'HOST]
(PACKFILENAME.STRING 'HOST HOST 'DEVICE [COND
((AND NODEVICE.IF.LOCAL (EQ HOST 'DSK))
NIL)
(T (OR (LISTGET NAMEFIELDS 'DEVICE)
(COND
(HOSTSPECIFIED NIL)
(T (LISTGET DEFAULTFIELDS 'DEVICE]
'DIRECTORY
[OR (LISTGET NAMEFIELDS 'DIRECTORY)
(COND
(HOSTSPECIFIED NIL)
(T (LISTGET DEFAULTFIELDS 'DIRECTORY]
'NAME
(OR (LISTGET NAMEFIELDS 'NAME)
(LISTGET DEFAULTFIELDS 'NAME))
'EXTENSION
(OR (LISTGET NAMEFIELDS 'EXTENSION)
(LISTGET DEFAULTFIELDS 'EXTENSION))
'VERSION
(COND
((AND NOVERSION.IF.LOCAL (EQ HOST 'DSK))
NIL)
(T (OR (LISTGET NAMEFIELDS 'VERSION)
(LISTGET DEFAULTFIELDS 'VERSION])
(TCPFTP.SERVER.MODE
[LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 15:38")
(* * This function parses USER commands)
(LET ((MODE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(RESPONSE.STRING)
(ERRORFLG))
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG MODE T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(SELECTQ MODE
(S (SETQ RESPONSE.STRING "Now in stream mode"))
(PROGN (SETQ RESPONSE.STRING (CONCAT "Unsupported mode - " MODE))
(SETQ ERRORFLG T)))
(COND
(ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
of TCPFTPCON))
NIL)
(T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.OPEN.DATA.CONNECTION
[LAMBDA (TCPFTPCON USERPORT FORINPUT) (* ejs%: "11-Apr-86 16:09")
(* * This function handles opening data connections and marking said tcp
connections as busy)
(bind (TCB ← (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))
DATASTREAM for RETRIES from 0 to TCPFTP.SERVER.RETRYCOUNT
until (SETQ DATASTREAM (TCP.OPEN (COND
(USERPORT (CAR USERPORT))
(T (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of TCB)))
(COND
(USERPORT (CDR USERPORT))
(T (fetch (TCP.CONTROL.BLOCK TCB.DST.PORT) of TCB)))
(SUB1 (fetch (TCP.CONTROL.BLOCK TCB.SRC.PORT) of TCB))
'ACTIVE
(COND
(FORINPUT 'INPUT)
(T 'OUTPUT))
T)) finally (RETURN (COND
(DATASTREAM (replace (TCPFTPCON
DATASTREAM)
of TCPFTPCON with
DATASTREAM
)
(replace (TCPFTPCON BUSY?)
of TCPFTPCON with (CREATE.EVENT
))
(* TELNET standard EOL convention on
DATASTREAMS)
(SETFILEINFO DATASTREAM
'EOL
'CRLF)
DATASTREAM)
(T (TCPFTP.SERVER.RESPONSE
426 "Couldn't open data connection"
(fetch (TCPFTPCON TCPOUT)
of TCPFTPCON))
NIL])
(TCPFTP.SERVER.PARSE.PORT
[LAMBDA (PSTRING) (* ; "Edited 28-May-87 18:00 by jop")
(* ;;; "Parse a port string, in the form 'h1,h2,h3,h4,p1,p2' , where the hx are bytes from an internet host address, and the px are bytes from a 16-bit TCP port number")
(LET ((IPADDRESS (CREATECELL \FIXP))
(TCPPORT 0))
(bind (BYTECOUNTER ← 0)
(ACCUMULATOR ← 0)
ERRORFLG for CH instring PSTRING do (COND
((EQ CH (CHARCODE %,))
(COND
((IGREATERP BYTECOUNTER 3)
(SETQ TCPPORT (IPLUS (ITIMES TCPPORT 256)
ACCUMULATOR)))
(T (\PUTBASEBYTE IPADDRESS BYTECOUNTER
ACCUMULATOR)))
(SETQ ACCUMULATOR 0)
(add BYTECOUNTER 1))
[(AND (ILEQ CH (CHARCODE 9))
(IGEQ CH (CHARCODE 0)))
(SETQ ACCUMULATOR (IPLUS (IDIFFERENCE
CH
(CHARCODE 0))
(ITIMES ACCUMULATOR
10)))
(COND
((IGREATERP ACCUMULATOR 255)
(SETQ ERRORFLG T)
(GO $$OUT]
(T (SETQ ERRORFLG T)
(GO $$OUT)))
finally (COND
(ERRORFLG (RETURN NIL))
(T (COND
((NEQ BYTECOUNTER 5)
(RETURN NIL))
(T (RETURN (CONS IPADDRESS (IPLUS (ITIMES TCPPORT 256)
ACCUMULATOR])
(TCPFTP.SERVER.PASSWORD
[LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 11:39")
(* * This function parses USER commands)
(LET ((PASS (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL)))
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG PASS T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(TCPFTP.SERVER.RESPONSE 230 "OK, so you're logged in. Now what?" (fetch (TCPFTPCON TCPOUT)
of TCPFTPCON])
(TCPFTP.SERVER.PATH
[LAMBDA (TCPFTPCON COMMAND.RDTBL OLDPATH) (* ejs%: "26-Sep-86 17:43")
(LET* [(NEWPATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
COMMAND.RDTBL))
[OLDFIELDS (COND
(NEWPATH (UNPACKFILENAME.STRING OLDPATH]
[NEWFIELDS (COND
(NEWPATH (UNPACKFILENAME.STRING (REPACKFILENAME.STRING NEWPATH 'INTERLISP]
(TRUEPATH (COND
(NEWPATH (PACKFILENAME.STRING 'HOST (OR (LISTGET NEWFIELDS 'HOST)
(LISTGET OLDFIELDS 'HOST))
'DEVICE
[OR (LISTGET NEWFIELDS 'DEVICE)
(COND
((LISTGET NEWFIELDS 'HOST)
NIL)
(T (LISTGET OLDFIELDS 'DEVICE]
'DIRECTORY
[OR (LISTGET NEWFIELDS 'DIRECTORY)
(COND
((LISTGET NEWFIELDS 'HOST)
NIL)
(T (LISTGET OLDFIELDS 'DIRECTORY]
'BODY OLDPATH]
(COND
(TRUEPATH (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Default pathname now " TRUEPATH)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
TRUEPATH)
(T (TCPFTP.SERVER.RESPONSE 501 (CONCAT "Couldn't interpret " NEWPATH " as a pathname")
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
NIL])
(TCPFTP.SERVER.PORT
[LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 11:41")
(LET* ((PORTSTRING (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(PARSEDPORT (TCPFTP.SERVER.PARSE.PORT PORTSTRING)))
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG PORTSTRING T)))
(COND
(PARSEDPORT (TCPFTP.SERVER.RESPONSE 200 (CONCAT "User port now " PORTSTRING)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
PARSEDPORT)
(T (TCPFTP.SERVER.RESPONSE 501 (CONCAT "Couldn't parse port specification " PORTSTRING)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
NIL])
(TCPFTP.SERVER.RENAME.FROM
[LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH) (* ejs%: "24-Mar-86 14:16")
(* * This function parses RNFR commands)
(LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
(TRUENAME (CAR (NLSETQ (INFILEP PACKED.FILENAME]
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(COND
(TRUENAME (TCPFTP.SERVER.RESPONSE 350 (CONCAT "About to rename "
(COND
(TCPFTP.SERVER.USE.TOPS20.SYNTAX
(REPACKFILENAME.STRING
(PACKFILENAME.STRING 'HOST NIL
'BODY TRUENAME)
'TOPS-20))
(T TRUENAME)))
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
TRUENAME)
(T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
NIL])
(TCPFTP.SERVER.RENAME.TO
[LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH FROM.FILE) (* ejs%: "24-Mar-86 14:34")
(* * This function parses RNTO commands)
(LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
(TRUENAME (CAR (NLSETQ (OUTFILEP PACKED.FILENAME]
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(COND
(TRUENAME (RENAMEFILE FROM.FILE TRUENAME)
(TCPFTP.SERVER.RESPONSE 250 (CONCAT "Renamed "
(COND
(TCPFTP.SERVER.USE.TOPS20.SYNTAX
(REPACKFILENAME.STRING (
PACKFILENAME.STRING
'HOST NIL
'BODY FROM.FILE)
'TOPS-20))
(T FROM.FILE))
" to "
(COND
(TCPFTP.SERVER.USE.TOPS20.SYNTAX
(REPACKFILENAME.STRING (
PACKFILENAME.STRING
'HOST NIL
'BODY TRUENAME)
'TOPS-20))
(T TRUENAME)))
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
(T (TCPFTP.SERVER.RESPONSE 553 (CONCAT "Couldn't make an output file named "
PACKED.FILENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.RESPONSE
[LAMBDA (CODE STRING STREAM) (* edited%: "21-Mar-86 11:44")
(RESETFORM (RADIX 10)
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG "> " CODE " " STRING T)))
(printout STREAM CODE " " STRING T))
(FORCEOUTPUT STREAM])
(TCPFTP.SERVER.RETRIEVE
[LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH) (* ejs%: "24-Mar-86 15:28")
(* * This function parses USER commands)
(LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
(TRUENAME (CAR (NLSETQ (INFILEP PACKED.FILENAME]
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(COND
[TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'INPUT 'OLD
`((TYPE %, TYPE]
(COND
[FILESTREAM
(TCPFTP.SERVER.RESPONSE
150
(CONCAT "Opening data connection for " (COND
(
TCPFTP.SERVER.USE.TOPS20.SYNTAX
(REPACKFILENAME.STRING
(FULLNAME FILESTREAM)
'TOPS-20))
(T (FULLNAME FILESTREAM)))
" ("
[\IP.ADDRESS.TO.STRING
(OR (CAR USERPORT)
(fetch (TCP.CONTROL.BLOCK TCB.DST.HOST)
of (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN)
of TCPFTPCON]
","
[OR (CDR USERPORT)
(fetch (TCP.CONTROL.BLOCK TCB.DST.PORT)
of (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN)
of TCPFTPCON]
") ("
(OR (GETFILEINFO FILESTREAM 'LENGTH)
0)
" bytes).")
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
(LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON
USERPORT)))
(COND
(DATASTREAM (LET [(RESULT (NLSETQ (COND
((EQ TYPE 'BINARY)
(COPYBYTES FILESTREAM
DATASTREAM))
(T (COPYCHARS FILESTREAM
DATASTREAM]
(CLOSEF? FILESTREAM)
(TCPFTP.SERVER.CLOSE.DATA.CONNECTION
TCPFTPCON)
(COND
(RESULT (TCPFTP.SERVER.RESPONSE
226 "Data transfer complete"
(fetch (TCPFTPCON TCPOUT)
of TCPFTPCON)))
(T (TCPFTP.SERVER.RESPONSE
426
"Couldn't complete retrieve operation"
(fetch (TCPFTPCON TCPOUT)
of TCPFTPCON]
(T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
(T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.STORE
[LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH) (* ejs%: "24-Mar-86 15:27")
(* * This function parses USER commands)
(LET*
[(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
(TRUENAME (CAR (NLSETQ (OUTFILEP PACKED.FILENAME]
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(COND
[TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'OUTPUT 'NEW
`((TYPE %, TYPE]
(COND
[FILESTREAM
(TCPFTP.SERVER.RESPONSE 150 (CONCAT
"Opening data connection for store of "
(FULLNAME FILESTREAM))
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
(LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT T
)))
(COND
(DATASTREAM [replace (STREAM ENDOFSTREAMOP) of DATASTREAM
with (FUNCTION (LAMBDA (STREAM)
(ERROR!]
(RESETLST (RESETSAVE (COND
((EQ TYPE 'BINARY)
(COPYBYTES DATASTREAM FILESTREAM))
(T (COPYCHARS DATASTREAM FILESTREAM
)))
(LIST [FUNCTION (LAMBDA (FILESTREAM
TCPFTPCON)
(CLOSEF? FILESTREAM)
(
TCPFTP.SERVER.CLOSE.DATA.CONNECTION
TCPFTPCON)
(TCPFTP.SERVER.RESPONSE
226
"Data transfer complete"
(fetch (TCPFTPCON
TCPOUT)
of TCPFTPCON]
FILESTREAM TCPFTPCON]
(T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
(T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "Unable to create output filename - " PACKED.FILENAME)
(fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.STRUCTURE
[LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 14:08")
(* * This function parses USER commands)
(LET ((STRUCTURE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(RESPONSE.STRING)
(ERRORFLG))
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG STRUCTURE T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(SELECTQ STRUCTURE
(F (SETQ RESPONSE.STRING "Now in stream mode"))
(PROGN (SETQ RESPONSE.STRING (CONCAT "Unsupported mode - " STRUCTURE))
(SETQ ERRORFLG T)))
(COND
(ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
of TCPFTPCON))
NIL)
(T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.TYPE
[LAMBDA (TCPFTPCON RDTBL) (* ejs%: "24-Mar-86 15:26")
(* * This function parses USER commands)
(LET* ((MAJOR.TYPE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
[MINOR.TYPE (LET [(TERM.CHAR (BIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON]
(COND
((EQ TERM.CHAR (CHARCODE SPACE))
(READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL))
(T (SELECTQ MAJOR.TYPE
(A 'N)
(L 8)
NIL]
(RESPONSE.STRING)
(ERRORFLG))
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG MAJOR.TYPE " " MINOR.TYPE T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(SELECTQ MAJOR.TYPE
(A (SELECTQ MINOR.TYPE
(N (SETQ RESPONSE.STRING "Type is now standard ASCII"))
(PROGN (SETQ RESPONSE.STRING (CONCAT "ASCII subtype " MINOR.TYPE
" not recognized"))
(SETQ ERRORFLG T))))
(E (SETQ RESPONSE.STRING "EBCDIC not supported")
(SETQ ERRORFLG T))
(I (SETQ RESPONSE.STRING "Type is now 8-bit binary"))
(L (COND
((NEQ MINOR.TYPE 8)
(SETQ RESPONSE.STRING (CONCAT "Binary byte size " MINOR.TYPE " not supported"))
(SETQ ERRORFLG T))
(T (SETQ RESPONSE.STRING "Type is now 8-bit binary"))))
NIL)
(COND
(ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
of TCPFTPCON))
NIL)
(T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
(SELECTQ MAJOR.TYPE
(A 'TEXT)
'BINARY])
(TCPFTP.SERVER.USER
[LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 11:39")
(* * This function parses USER commands)
(LET ((USER (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
RDTBL)))
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG USER T)))
(DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
(TCPFTP.SERVER.RESPONSE 230 "Hi, there!" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])
(TCPFTP.SERVER.VERBOSE.LIST
[LAMBDA (FILE STREAM) (* edited%: "26-Mar-86 11:32")
(printout STREAM (COND
(TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (PACKFILENAME.STRING
'HOST NIL
'BODY
(FULLNAME FILE))
'TOPS-20))
(T (FULLNAME FILE)))
";P775252;AFORYOURSELF,"
(FOLDHI (OR (GETFILEINFO FILE 'SIZE)
0)
4)
","
(GETFILEINFO FILE 'CREATIONDATE)
","
(GETFILEINFO FILE 'WRITEDATE)
T])
(TCPFTP.SERVER.WAIT.FOR.IDLE
[LAMBDA (TCPFTPCON) (* ejs%: "20-Mar-86 16:39")
(bind BUSY? while (SETQ BUSY? (fetch (TCPFTPCON BUSY?) of TCPFTPCON)) do (AWAIT.EVENT BUSY?])
(TCPFTP.UNIX.LS.DATE
[LAMBDA (FILE) (* edited%: "21-Mar-86 13:38")
(LET* [(CREATIONDATE (GETFILEINFO FILE 'CREATIONDATE))
(MONTHPOS (STRPOS "-" CREATIONDATE))
(YEARPOS (STRPOS "-" CREATIONDATE (ADD1 MONTHPOS)))
(TIMEPOS (ADD1 (STRPOS " " CREATIONDATE]
(CONCAT (SUBSTRING CREATIONDATE (ADD1 MONTHPOS)
(SUB1 YEARPOS))
" "
(SUBSTRING CREATIONDATE 1 (SUB1 MONTHPOS))
" "
(SUBSTRING CREATIONDATE TIMEPOS -4])
)
(RPAQ? TCPFTP.SERVER.HERALD.STRING "Xerox Lisp FTP Service 0.9 at your service")
(RPAQ? TCPFTP.SERVER.USE.TOPS20.SYNTAX T)
(RPAQ? TCPFTP.SERVER.RETRYCOUNT 5)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS TCPFTP.SERVER.HERALD.STRING TCPFTP.SERVER.USE.TOPS20.SYNTAX TCPFTP.SERVER.RETRYCOUNT)
)
(FILESLOAD (SYSLOAD)
TCPFTP)
(PUTPROPS TCPFTPSRV COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1639 52394 (TCPFTP.SERVER 1649 . 3822) (TCPFTP.SERVER.ABORTED 3824 . 3996) (
TCPFTP.SERVER.ACCOUNT 3998 . 4550) (TCPFTP.SERVER.APPEND 4552 . 8264) (
TCPFTP.SERVER.CLOSE.DATA.CONNECTION 8266 . 8764) (TCPFTP.SERVER.COMMAND.LOOP 8766 . 14097) (
TCPFTP.SERVER.CONNECTED.INFO 14099 . 15085) (TCPFTP.SERVER.DELETE 15087 . 16972) (
TCPFTP.SERVER.DIRECTORY 16974 . 18954) (TCPFTP.SERVER.EXIT 18956 . 19148) (TCPFTP.SERVER.IDLE.INFO
19150 . 19315) (TCPFTP.SERVER.LIST 19317 . 21756) (TCPFTP.SERVER.MERGE.PATHNAMES 21758 . 23542) (
TCPFTP.SERVER.MODE 23544 . 24567) (TCPFTP.SERVER.OPEN.DATA.CONNECTION 24569 . 27556) (
TCPFTP.SERVER.PARSE.PORT 27558 . 30266) (TCPFTP.SERVER.PASSWORD 30268 . 30914) (TCPFTP.SERVER.PATH
30916 . 32819) (TCPFTP.SERVER.PORT 32821 . 33630) (TCPFTP.SERVER.RENAME.FROM 33632 . 35204) (
TCPFTP.SERVER.RENAME.TO 35206 . 37687) (TCPFTP.SERVER.RESPONSE 37689 . 38008) (TCPFTP.SERVER.RETRIEVE
38010 . 43085) (TCPFTP.SERVER.STORE 43087 . 46736) (TCPFTP.SERVER.STRUCTURE 46738 . 47791) (
TCPFTP.SERVER.TYPE 47793 . 50081) (TCPFTP.SERVER.USER 50083 . 50622) (TCPFTP.SERVER.VERBOSE.LIST 50624
. 51540) (TCPFTP.SERVER.WAIT.FOR.IDLE 51542 . 51789) (TCPFTP.UNIX.LS.DATE 51791 . 52392)))))
STOP