(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Jul-87 10:52:03" {ERIS}<LISPCORE>LIBRARY>TCPTFTP.;27 53563
changes to%: (FNS \TFTP.SEND.FILE)
previous date%: "15-Apr-87 20:56:29" {ERIS}<LISPCORE>LIBRARY>TCPTFTP.;26)
(* "
Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT TCPTFTPCOMS)
(RPAQQ TCPTFTPCOMS ((COMS
(* ;; "Trivial File Transfer Protocol")
(INITVARS (\TFTP.DEVICE)
(TFTP.MAXRETRIES 20))
(GLOBALVARS \TFTP.DEVICE TFTP.MAXRETRIES)
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS TFTPCON TFTP TFTPSTREAM)
(CONSTANTS (\TFTPOVLEN 4)
(\TFTP.SOCKET 69))
(CONSTANTS * TFTPOPCODES)))
(INITVARS (TFTP.MAXRETRIES 20))
(FNS \TFTP.ACKNOWLEDGE \TFTP.CLOSEFILE \TFTP.EOFP \TFTP.ERROR
\TFTP.GETNEXTBUFFER \TFTP.INIT \TFTP.INPUT.BUFFER \TFTP.OPENFILE
\TFTP.READP \TFTP.SEND.ERROR \TFTP.SETUP)
(FILES (SYSLOAD)
TCPUDP))
(COMS
(* ;; "TFTP Server functions")
(INITVARS (\TFTP.SERVER.CONNECTIONS))
(GLOBALVARS \TFTP.SERVER.CONNECTIONS)
(FNS TFTP.SERVER.PROCESS \TFTP.GET.FILE \TFTP.SEND.FILE))
(COMS
(* ;; "User functions")
(FNS TFTP.SERVER TFTP.GET TFTP.PUT))
(COMS
(* ;; "Tracing functions")
(FNS PRINTTFTP \TFTP.PRINT.ACK \TFTP.PRINT.DATA \TFTP.PRINT.ERROR
\TFTP.PRINT.REQUEST))
(P (\TFTP.INIT))))
(* ;; "Trivial File Transfer Protocol")
(RPAQ? \TFTP.DEVICE )
(RPAQ? TFTP.MAXRETRIES 20)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \TFTP.DEVICE TFTP.MAXRETRIES)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")
(DECLARE%: EVAL@COMPILE
(RECORD TFTPCON (UDPSOCKET DESTSOCKET STREAM HOST))
(ACCESSFNS TFTP ((TFTPBASE (fetch (UDP UDPCONTENTS) of DATUM)))
(BLOCKRECORD TFTPBASE ((OPCODE WORD)
(BLOCK# WORD)))
[ACCESSFNS TFTP ((TFTPCONTENTS (\ADDBASE (fetch (UDP UDPCONTENTS) of DATUM)
(FOLDHI \TFTPOVLEN BYTESPERWORD]
(BLOCKRECORD TFTPBASE ((NIL WORD)
(ERRORCODE WORD))))
(ACCESSFNS TFTPSTREAM ((TFTPCON (fetch (STREAM F1) of DATUM)
(replace (STREAM F1) of DATUM with NEWVALUE))
(LASTPACKETIN (fetch (STREAM F2) of DATUM)
(replace (STREAM F2) of DATUM with NEWVALUE))))
)
(DECLARE%: EVAL@COMPILE
(RPAQQ \TFTPOVLEN 4)
(RPAQQ \TFTP.SOCKET 69)
(CONSTANTS (\TFTPOVLEN 4)
(\TFTP.SOCKET 69))
)
(RPAQQ TFTPOPCODES ((\TFTP.RRQ 1)
(\TFTP.WRQ 2)
(\TFTP.DATA 3)
(\TFTP.ACK 4)
(\TFTP.ERROR 5)))
(DECLARE%: EVAL@COMPILE
(RPAQQ \TFTP.RRQ 1)
(RPAQQ \TFTP.WRQ 2)
(RPAQQ \TFTP.DATA 3)
(RPAQQ \TFTP.ACK 4)
(RPAQQ \TFTP.ERROR 5)
(CONSTANTS (\TFTP.RRQ 1)
(\TFTP.WRQ 2)
(\TFTP.DATA 3)
(\TFTP.ACK 4)
(\TFTP.ERROR 5))
)
(* "END EXPORTED DEFINITIONS")
)
(RPAQ? TFTP.MAXRETRIES 20)
(DEFINEQ
(\TFTP.ACKNOWLEDGE
[LAMBDA (STREAM ACK#) (* MPL " 2-Jun-85 17:07")
(LET ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM))
(ACK (\ALLOCATE.ETHERPACKET)))
(\TFTP.SETUP ACK TFTPCON \TFTP.ACK 'FREE)
(UDP.APPEND.WORD ACK ACK#)
(UDP.SEND (fetch (TFTPCON UDPSOCKET) of TFTPCON)
ACK)
(BLOCK)
(COND
((AND (EQ (fetch (STREAM ACCESS) of STREAM)
'INPUT)
(fetch (TFTPSTREAM LASTPACKETIN) of STREAM))
(UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON])
(\TFTP.CLOSEFILE
[LAMBDA (STREAM) (* ejs%: " 9-Feb-85 23:47")
(LET ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM)))
(SELECTQ (fetch (STREAM ACCESS) of STREAM)
(OUTPUT [COND
((AND (fetch (STREAM CBUFPTR) of STREAM)
(NOT (fetch (TFTPSTREAM LASTPACKETIN) of STREAM)))
(\TFTP.GETNEXTBUFFER STREAM 'WRITE])
NIL)
(UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)
T)
(replace (STREAM ACCESS) of STREAM with NIL)
STREAM])
(\TFTP.EOFP
[LAMBDA (STREAM) (* ejs%: " 9-Feb-85 21:23")
(OR (NULL (fetch (STREAM CBUFPTR) of STREAM))
(AND (fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
(EQ (fetch (STREAM COFFSET) of STREAM)
(fetch (STREAM CBUFSIZE) of STREAM])
(\TFTP.ERROR
[LAMBDA (TFTP TFTPCON) (* ejs%: " 9-Feb-85 19:04")
(* * Called upon receipt of error packet in TFTP stream)
(LET [(ERRORSTRING (ALLOCSTRING (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
(CONSTANT (IPLUS \UDPOVLEN (ADD1 \TFTPOVLEN]
(\MOVEBYTES (fetch (TFTP TFTPCONTENTS) of TFTP)
0
(fetch (STRINGP BASE) of ERRORSTRING)
(fetch (STRINGP OFFST) of ERRORSTRING)
(fetch (STRINGP LENGTH) of ERRORSTRING))
(ERROR (CONCAT "TFTP error message: " ERRORSTRING " for code")
(fetch (TFTP ERRORCODE) of TFTP])
(\TFTP.GETNEXTBUFFER
[LAMBDA (STREAM WHATFOR NOERRORFLG) (* MPL " 2-Jun-85 19:48")
(DECLARE (GLOBALVARS TFTP.MAXRETRIES))
(LET*
((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM))
(IPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
(RETRYCOUNT 0)
(BUFFER (fetch (STREAM CBUFPTR) of STREAM))
UDP)
(SELECTQ WHATFOR
(READ [COND
[(fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
(replace (STREAM ACCESS) of STREAM with NIL)
(\RELEASE.ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM))
(replace (STREAM CBUFPTR) of STREAM with NIL)
(COND
(NOERRORFLG NIL)
(T (\EOF.ACTION STREAM]
(T (PROG [(NEXT# (COND
(BUFFER (ADD1 (fetch (TFTP BLOCK#) of BUFFER)))
(T 1]
LP [for I from 1 to TFTP.MAXRETRIES until UDP
do (SETQ UDP (UDP.GET IPSOCKET \ETHERTIMEOUT))
(COND
((NOT UDP)
(\TFTP.ACKNOWLEDGE STREAM (SUB1 NEXT#]
(COND
[UDP (COND
[(EQ (fetch (TFTP OPCODE) of UDP)
\TFTP.DATA)
(COND
((IEQP (fetch (TFTP BLOCK#) of UDP)
NEXT#)
(\TFTP.INPUT.BUFFER STREAM UDP)
(\TFTP.ACKNOWLEDGE STREAM NEXT#)
(RETURN T))
[(ILESSP (fetch (TFTP BLOCK#) of UDP)
NEXT#)
[COND
(IPTRACEFLG (COND
((EQ IPTRACEFLG T)
(printout IPTRACEFILE
"Retransmitting ACK for block "
(SUB1 NEXT#)
T))
(T (PRIN1 "R" IPTRACEFILE]
(\TFTP.ACKNOWLEDGE STREAM (SUB1 NEXT#))
(\RELEASE.ETHERPACKET UDP)
(SETQ UDP NIL)
(COND
((EQ (add RETRYCOUNT 1)
TFTP.MAXRETRIES)
(\TFTP.SEND.ERROR TFTPCON 0
"Timeout awaiting next data packet; aborting")
(replace (STREAM STRMBINFN) of STREAM
with (FUNCTION \STREAM.NOT.OPEN))
(ERROR "Timeout awaiting next data packet; aborting"
STREAM))
(T (GO LP]
(T (\TFTP.SEND.ERROR TFTPCON 0
"Protocol error: Block # too high. Aborting...")
(replace (STREAM STRMBINFN) of STREAM
with (FUNCTION \STREAM.NOT.OPEN))
(ERROR "Protocol error: Block # too high. Aborting..."
STREAM]
((EQ (fetch (TFTP OPCODE) of UDP)
\TFTP.ERROR)
(replace (STREAM STRMBINFN) of STREAM
with (FUNCTION STREAM.NOT.OPEN))
(\TFTP.ERROR UDP TFTPCON))
(T [\TFTP.SEND.ERROR TFTPCON 0
(CONCAT
"Protocol error: Illegal TFTP opcode, expected DATA but got "
(SELECTC (fetch (TFTP OPCODE) of UDP)
(\TFTP.RRQ "read request.")
(\TFTP.WRQ "write request.")
(\TFTP.ACK "ack.")
(CONCAT "unknown type "
(fetch (TFTP OPCODE) of UDP)
"."]
(replace (STREAM STRMBINFN) of STREAM
with (FUNCTION \STREAM.NOT.OPEN))
(ERROR "Illegal TFTP opcode rec'd" STREAM]
(T (\TFTP.SEND.ERROR TFTPCON 0
"Timeout awaiting next data packet; aborting")
(replace (STREAM STRMBINFN) of STREAM with (FUNCTION
\STREAM.NOT.OPEN))
(ERROR "Timeout awaiting next data packet; aborting" STREAM])
(WRITE [COND
[(fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
(replace (STREAM ACCESS) of STREAM with NIL)
(COND
(NOERRORFLG NIL)
(T (\EOF.ACTION STREAM]
(T (PROG (ACK# NBYTES)
(SETQ ACK# (fetch (TFTP BLOCK#) of BUFFER))
(SETQ NBYTES (IDIFFERENCE (fetch (STREAM COFFSET) of STREAM)
(UNFOLD (IDIFFERENCE (\LOLOC (fetch (TFTP
TFTPCONTENTS
)
of BUFFER))
(\LOLOC BUFFER))
BYTESPERWORD)))
[replace (IP IPTOTALLENGTH) of BUFFER
with (IPLUS NBYTES (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN \IPOVLEN]
[replace (UDP UDPLENGTH) of BUFFER with (IPLUS NBYTES
(CONSTANT (IPLUS \UDPOVLEN
\TFTPOVLEN
]
(COND
((ILESSP NBYTES 512)
(replace (TFTPSTREAM LASTPACKETIN) of STREAM with T)))
LP (for I from 1 to TFTP.MAXRETRIES until UDP
do (SETQ UDP (UDP.EXCHANGE IPSOCKET BUFFER)))
(COND
[(AND UDP (EQ (fetch (TFTP OPCODE) of UDP)
\TFTP.ACK))
(COND
((EQ (fetch (TFTP BLOCK#) of UDP)
ACK#)
[COND
((EQ NBYTES 512)
(\TFTP.SETUP UDP TFTPCON \TFTP.DATA NIL)
(UDP.APPEND.WORD UDP (ADD1 ACK#))
(replace (UDP UDPLENGTH) of UDP
with (CONSTANT (IPLUS 512 \UDPOVLEN \TFTPOVLEN)))
(\TFTP.INPUT.BUFFER STREAM UDP))
(T (replace (STREAM CBUFPTR) of STREAM with NIL)
(replace (STREAM ACCESS) of STREAM with NIL)
(UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON]
(RETURN T))
[(ILESSP (fetch (TFTP BLOCK#) of UDP)
ACK#)
[COND
(IPTRACEFLG (COND
((EQ IPTRACEFLG T)
(printout IPTRACEFILE
"TFTP retransmission on block# " ACK# T
))
(T (PRIN1 "R" IPTRACEFILE]
(\RELEASE.ETHERPACKET UDP)
(SETQ UDP NIL)
(COND
[(EQ (add RETRYCOUNT 1)
TFTP.MAXRETRIES)
(\TFTP.SEND.ERROR TFTPCON 0
"Timeout awaiting acknowledgement. Aborting...")
(replace (STREAM STRMBOUTFN) of STREAM
with (FUNCTION \STREAM.NOT.OPEN))
(COND
(NOERRORFLG NIL)
(T (\EOF.ACTION STREAM]
(T (GO LP]
(T (\TFTP.SEND.ERROR TFTPCON 0
"Protocol error: Block # too high. Aborting...")
(replace (STREAM STRMBOUTFN) of STREAM
with (FUNCTION \STREAM.NOT.OPEN))
(COND
(NOERRORFLG NIL)
(T (\EOF.ACTION STREAM]
((AND UDP (EQ (fetch (TFTP OPCODE) of UDP)
\TFTP.ERROR))
(replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION
\STREAM.NOT.OPEN))
(\TFTP.ERROR UDP TFTPCON))
[UDP [\TFTP.SEND.ERROR TFTPCON 0
(CONCAT
"Protocol error: Illegal TFTP opcode, expected ACK but got "
(SELECTC (fetch (TFTP OPCODE) of UDP)
(\TFTP.RRQ "read request.")
(\TFTP.WRQ "write request.")
(\TFTP.DATA "data.")
(CONCAT "unknown type " (fetch (TFTP OPCODE)
of UDP)
"."]
(replace (STREAM STRMBOUTFN) of STREAM
with (FUNCTION \STREAM.NOT.OPEN))
(COND
(NOERRORFLG NIL)
(T (\EOF.ACTION STREAM]
(T (\TFTP.SEND.ERROR TFTPCON 0 "Protocol error, aborting...")
(replace (STREAM STRMBOUTFN) of STREAM
with (FUNCTION \STREAM.NOT.OPEN))
(COND
(NOERRORFLG NIL)
(T (\EOF.ACTION STREAM])
(ERROR "Illegal ACCESS" WHATFOR])
(\TFTP.INIT
[LAMBDA NIL (* ejs%: " 2-Feb-86 12:00")
(DECLARE (GLOBALVARS \TFTP.DEVICE))
(OR \TFTP.DEVICE
(\DEFINEDEVICE NIL
(SETQ \TFTP.DEVICE
(create FDEV
FDBINABLE ← T
FDBOUTABLE ← T
NODIRECTORIES ← T
RESETABLE ← NIL
RANDOMACCESSP ← NIL
BUFFERED ← T
PAGEMAPPED ← NIL
DEVICENAME ← 'TFTP
HOSTNAMEP ← (FUNCTION NILL)
EVENTFN ← (FUNCTION NILL)
FORCEOUTPUT ← (FUNCTION NILL)
BIN ← (FUNCTION \BUFFERED.BIN)
BOUT ← (FUNCTION \BUFFERED.BOUT)
GETNEXTBUFFER ← (FUNCTION \TFTP.GETNEXTBUFFER)
READP ← (FUNCTION \TFTP.READP)
EOFP ← (FUNCTION \TFTP.EOFP)
CLOSEFILE ← (FUNCTION \TFTP.CLOSEFILE])
(\TFTP.INPUT.BUFFER
[LAMBDA (STREAM UDP) (* ejs%: " 9-Feb-85 20:51")
(* * Sets up the fields of the stream necessary to support buffered operation,
with UDP as the next packet)
(LET [(OFFSET (UNFOLD (IDIFFERENCE (\LOLOC (fetch (TFTP TFTPCONTENTS) of UDP))
(\LOLOC UDP))
BYTESPERWORD))
(LENGTH (IDIFFERENCE (fetch (UDP UDPLENGTH) of UDP)
(CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN]
[COND
((type? ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM))
(\RELEASE.ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM]
(replace (STREAM CBUFPTR) of STREAM with UDP)
(replace (STREAM COFFSET) of STREAM with OFFSET)
(replace (STREAM CBUFSIZE) of STREAM with (replace (STREAM CBUFMAXSIZE) of STREAM
with (IPLUS OFFSET LENGTH)))
(COND
((ILESSP LENGTH 512)
(replace (TFTPSTREAM LASTPACKETIN) of STREAM with T])
(\TFTP.OPENFILE
[LAMBDA (FILENAME ACCESS RECOG PARAMETERS) (* ejs%: "15-Sep-85 17:48")
(* * Open a file using TFTP)
(LET* ((HOSTNAME (FILENAMEFIELD FILENAME 'HOST))
[DEVICE (COND
((DODIP.HOSTP HOSTNAME)
(create FDEV using \TFTP.DEVICE DEVICENAME ← HOSTNAME))
(T (ERROR "Unknown IP host: " HOSTNAME]
(STREAM (create STREAM
DEVICE ← DEVICE))
[TFTPCON (replace (FDEV DEVICEINFO) of DEVICE with (create TFTPCON
UDPSOCKET ← (UDP.OPEN.SOCKET)
STREAM ← STREAM
HOST ← (DODIP.HOSTP HOSTNAME]
(UDP (\ALLOCATE.ETHERPACKET))
UDPIN)
(RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SOCKET)
(AND RESETSTATE (UDP.CLOSE.SOCKET SOCKET T]
(fetch (TFTPCON UDPSOCKET) of TFTPCON)))
(replace (TFTPCON DESTSOCKET) of TFTPCON with \TFTP.SOCKET)
(\TFTP.SETUP UDP TFTPCON (SELECTQ ACCESS
(INPUT \TFTP.RRQ)
(OUTPUT \TFTP.WRQ)
(ERROR "ACCESS must be INPUT or OUTPUT" ACCESS)))
(UDP.APPEND.STRING UDP (SUBATOM FILENAME (STRPOS '} FILENAME NIL NIL NIL T)))
(UDP.APPEND.BYTE UDP 0)
(UDP.APPEND.STRING UDP (COND
((EQ (CADR (FASSOC 'TYPE PARAMETERS))
'BINARY)
"OCTET")
(T "NETASCII")))
(UDP.APPEND.BYTE UDP 0)
(for I from 1 to \MAXETHERTRIES do (SETQ UDPIN (UDP.EXCHANGE (fetch (TFTPCON
UDPSOCKET
)
of TFTPCON)
UDP)) until UDPIN
finally (\RELEASE.ETHERPACKET UDP))
(COND
[UDPIN (SELECTC (fetch (TFTP OPCODE) of UDPIN)
(\TFTP.ACK (COND
((AND (EQ ACCESS 'OUTPUT)
(EQ (fetch (TFTP BLOCK#) of UDPIN)
0))
(replace (TFTPSTREAM TFTPCON) of STREAM with TFTPCON)
(replace (STREAM ACCESS) of STREAM with ACCESS)
(replace (STREAM FULLFILENAME) of STREAM with FILENAME)
(replace (TFTPCON DESTSOCKET) of TFTPCON
with (fetch (UDP UDPSOURCEPORT) of UDPIN))
(\TFTP.SETUP UDPIN TFTPCON \TFTP.DATA NIL)
(UDP.APPEND.WORD UDPIN 1)
(add (fetch (UDP UDPLENGTH) of UDPIN)
512)
(\TFTP.INPUT.BUFFER STREAM UDPIN)
STREAM)))
(\TFTP.DATA (COND
((AND (EQ ACCESS 'INPUT)
(EQ (fetch (TFTP BLOCK#) of UDPIN)
1))
(replace (TFTPSTREAM TFTPCON) of STREAM with TFTPCON)
(replace (STREAM ACCESS) of STREAM with ACCESS)
(replace (STREAM FULLFILENAME) of STREAM with FILENAME
)
(replace (TFTPCON DESTSOCKET) of TFTPCON
with (fetch (UDP UDPSOURCEPORT) of UDPIN))
(\TFTP.INPUT.BUFFER STREAM UDPIN)
(\TFTP.ACKNOWLEDGE STREAM 1)
STREAM)))
(\TFTP.ERROR (\TFTP.ERROR UDPIN))
(ERROR "Unknown TFTP opcode" (fetch (TFTP OPCODE) of UDPIN]
(T (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)
T)
NIL])
(\TFTP.READP
[LAMBDA (STREAM) (* ejs%: " 9-Feb-85 20:48")
(ILESSP (fetch (STREAM COFFSET) of STREAM)
(fetch (STREAM CBUFSIZE) of STREAM])
(\TFTP.SEND.ERROR
[LAMBDA (TFTPCON ERRORCODE ERRORSTRING) (* ejs%: " 1-Jun-85 15:34")
(* * Send an error back to the requestor)
(LET ((TFTP (\ALLOCATE.ETHERPACKET)))
(\TFTP.SETUP TFTP TFTPCON \TFTP.ERROR NIL)
(UDP.APPEND.WORD TFTP ERRORCODE)
(UDP.APPEND.STRING TFTP ERRORSTRING)
(UDP.APPEND.BYTE TFTP 0)
(UDP.SEND (fetch (TFTPCON UDPSOCKET) of TFTPCON)
TFTP])
(\TFTP.SETUP
[LAMBDA (UDP TFTPCON OPCODE REQUEUE) (* ejs%: " 9-Feb-85 20:32")
(UDP.SETUP UDP (fetch (TFTPCON HOST) of TFTPCON)
(fetch (TFTPCON DESTSOCKET) of TFTPCON)
0
(fetch (TFTPCON UDPSOCKET) of TFTPCON))
(replace EPREQUEUE of UDP with REQUEUE)
(UDP.APPEND.WORD UDP OPCODE])
)
(FILESLOAD (SYSLOAD)
TCPUDP)
(* ;; "TFTP Server functions")
(RPAQ? \TFTP.SERVER.CONNECTIONS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \TFTP.SERVER.CONNECTIONS)
)
(DEFINEQ
(TFTP.SERVER.PROCESS
[LAMBDA (LOGSTREAM) (* ejs%: " 3-Jun-85 01:52")
(* * A server for TFTP file transfer)
(DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
(LET*
((DEVICE (create FDEV using \TFTP.DEVICE DEVICENAME ← 'TFTPSERVER))
(SERVERSOCKET (UDP.OPEN.SOCKET \TFTP.SOCKET T))
CONNECTION)
[COND
((NULL LOGSTREAM)
(COND
((NOT (HASTTYWINDOWP))
(\CREATE.TTYDISPLAYSTREAM)))
(SETQ LOGSTREAM (TTYDISPLAYSTREAM]
(SETQ \TFTP.SERVER.CONNECTIONS NIL)
(COND
(SERVERSOCKET
(RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SOCKET)
(UDP.CLOSE.SOCKET SOCKET T]
SERVERSOCKET))
(while T
do (LET ((UDP (UDP.GET SERVERSOCKET T)))
(SETQ CONNECTION (CONS (fetch (IP IPSOURCEADDRESS) of UDP)
(fetch (UDP UDPSOURCEPORT) of UDP)))
(COND
[(NOT (MEMBER CONNECTION \TFTP.SERVER.CONNECTIONS))
(push \TFTP.SERVER.CONNECTIONS CONNECTION)
(SELECTC (fetch (TFTP OPCODE) of UDP)
(\TFTP.RRQ (ADD.PROCESS `(\TFTP.SEND.FILE %, UDP
(QUOTE %, (create TFTPCON
UDPSOCKET ←
(UDP.OPEN.SOCKET)
))
%, DEVICE %, LOGSTREAM)))
(\TFTP.WRQ (ADD.PROCESS `(\TFTP.GET.FILE %, UDP
(QUOTE %, (create TFTPCON
UDPSOCKET ←
(UDP.OPEN.SOCKET)
))
%, DEVICE %, LOGSTREAM)))
(PROGN (printout LOGSTREAM "TFTP Server: Unexpected opcode "
(fetch (TFTP OPCODE) of UDP)
T)
(SETQ \TFTP.SERVER.CONNECTIONS (DREMOVE CONNECTION
\TFTP.SERVER.CONNECTIONS
))
(\RELEASE.ETHERPACKET UDP]
(T (* Duplicate request)
(\RELEASE.ETHERPACKET UDP])
(\TFTP.GET.FILE
[LAMBDA (UDP TFTPCON DEVICE LOGSTREAM) (* ; "Edited 14-Apr-87 20:19 by FS")
(* ;; "Try to start receiving a file from the requestor as directed by the contents of the received UDP packet")
(DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
(LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
of UDP)
I))
finally (RETURN (IDIFFERENCE I BYTESPERWORD]
(FILENAME (ALLOCSTRING FILENAMELENGTH))
[MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP)
I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD
FILENAMELENGTH
1]
(MODE (ALLOCSTRING MODELENGTH))
(HOST (fetch (IP IPSOURCEADDRESS) of UDP))
FILE TYPE TFTPSTREAM RESULT)
(RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (TFTPCON)
(LET* [(UDPSOCKET (fetch (TFTPCON UDPSOCKET)
of TFTPCON))
(CONNECTION (CONS (fetch (TFTPCON HOST)
of TFTPCON)
(fetch (TFTPCON
DESTSOCKET
)
of TFTPCON]
(SETQ \TFTP.SERVER.CONNECTIONS
(REMOVE CONNECTION
\TFTP.SERVER.CONNECTIONS))
(AND RESETSTATE (UDP.CLOSE.SOCKET
UDPSOCKET T]
TFTPCON))
(replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT)
of UDP))
(replace (TFTPCON HOST) of TFTPCON with HOST)
(* ;; "Read the filename out of the packet")
(\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
BYTESPERWORD
(fetch (STRINGP BASE) of FILENAME)
(fetch (STRINGP OFFST) of FILENAME)
FILENAMELENGTH)
(* ;; "Read the mode out of the packet")
(\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
(IPLUS BYTESPERWORD FILENAMELENGTH 1)
(fetch (STRINGP BASE) of MODE)
(fetch (STRINGP OFFST) of MODE)
MODELENGTH)
(SETQ MODE (U-CASE MODE))
(printout LOGSTREAM "TFTP Server: Will attempt to receive " FILENAME " in " MODE
" mode from host " (\IP.ADDRESS.TO.STRING HOST)
T)
(SETQ RESULT
(COND
[[AND (SETQ TYPE (COND
((STREQUAL MODE "NETASCII")
'TEXT)
((STREQUAL MODE "OCTET")
'BINARY)
(T (\TFTP.SEND.ERROR TFTPCON 0 (CONCAT
"Unknown transfer type--"
MODE))
NIL)))
(SETQ FILE (LET [(OUTSTREAM
(CAR (NLSETQ (OPENSTREAM FILENAME 'OUTPUT 'NEW
(LIST (LIST 'TYPE TYPE]
(COND
((NULL OUTSTREAM)
(\TFTP.SEND.ERROR TFTPCON 1 (CONCAT
"Can't open file--"
FILENAME))
NIL)
(T OUTSTREAM]
(* ;; "Mode is OK, and file is open for input. Open the TFTP stream back to the requestor")
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FILE)
(COND
(RESETSTATE (CLOSEF? FILE)
(DELFILE (FULLNAME FILE]
FILE))
(SETQ TFTPSTREAM (create STREAM
DEVICE ← DEVICE))
(replace (TFTPCON STREAM) of TFTPCON with TFTPSTREAM)
(replace (STREAM ACCESS) of TFTPSTREAM with 'INPUT)
(replace (TFTPSTREAM TFTPCON) of TFTPSTREAM with TFTPCON)
(* ;; "Send the first acknowledgement")
(\TFTP.ACKNOWLEDGE TFTPSTREAM 0)
(\RELEASE.ETHERPACKET UDP)
(printout LOGSTREAM "TFTP Server: receiving " (FULLNAME FILE)
T)
(COND
((NLSETQ (COPYBYTES TFTPSTREAM FILE))
(printout LOGSTREAM "TFTP Server: Done receiving " (FULLNAME FILE)
T)
(CLOSEF? FILE))
(T (printout LOGSTREAM "TFTP Server: Failed to receive " (FULLNAME FILE)
T)
(DELFILE (FULLNAME (CLOSEF? FILE]
(T (printout LOGSTREAM "TFTP Server: Failed to receive " (FULLNAME FILE)
T)
(\RELEASE.ETHERPACKET UDP)
NIL)))
(* ;; "Remove connection from list.")
(LET (UDPSOCKET CONNECTION)
(SETQ UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
(SETQ CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON)
(fetch (UDP UDPDESTPORT) of UDPSOCKET)))
(SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS)))
RESULT])
(\TFTP.SEND.FILE
[LAMBDA (UDP TFTPCON DEVICE LOGSTREAM) (* ; "Edited 30-Jun-87 22:12 by scp")
(* ;; "Try to start sending a file to the requestor as directed by the contents of the received UDP packet")
(DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
(LET*
([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
of UDP)
I))
finally (RETURN (IDIFFERENCE I BYTESPERWORD]
(FILENAME (ALLOCSTRING FILENAMELENGTH))
[MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP)
I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD
FILENAMELENGTH 1]
(MODE (ALLOCSTRING MODELENGTH))
(HOST (fetch (IP IPSOURCEADDRESS) of UDP))
FILE TYPE TFTPSTREAM RESULT)
(RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (TFTPCON)
(LET* [(UDPSOCKET (fetch (TFTPCON UDPSOCKET)
of TFTPCON))
(CONNECTION (CONS (fetch (TFTPCON HOST)
of TFTPCON)
(fetch (TFTPCON DESTSOCKET)
of TFTPCON]
(SETQ \TFTP.SERVER.CONNECTIONS (REMOVE
CONNECTION
\TFTP.SERVER.CONNECTIONS
))
(AND RESETSTATE (UDP.CLOSE.SOCKET UDPSOCKET T]
TFTPCON))
(replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT) of UDP))
(replace (TFTPCON HOST) of TFTPCON with HOST)
(* ;; "Read the filename out of the packet")
(\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
BYTESPERWORD
(fetch (STRINGP BASE) of FILENAME)
(fetch (STRINGP OFFST) of FILENAME)
FILENAMELENGTH)
(* ;; "Read the mode out of the packet")
(\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
(IPLUS BYTESPERWORD FILENAMELENGTH 1)
(fetch (STRINGP BASE) of MODE)
(fetch (STRINGP OFFST) of MODE)
MODELENGTH)
(SETQ MODE (U-CASE MODE))
(printout LOGSTREAM "TFTP Server: Will attempt to send " FILENAME " in " MODE
" mode to host " (\IP.ADDRESS.TO.STRING HOST)
T)
(SETQ RESULT
(COND
([AND (SETQ TYPE (COND
((STREQUAL MODE "NETASCII")
'TEXT)
((STREQUAL MODE "OCTET")
'BINARY)
(T (\TFTP.SEND.ERROR TFTPCON 0 (CONCAT "Unknown transfer type--"
MODE))
NIL)))
(SETQ FILE
(LET* [(FULLFILENAME (INFILEP FILENAME))
(INSTREAM (AND FULLFILENAME
(CAR (NLSETQ (OPENSTREAM FULLFILENAME 'INPUT
'OLD
(LIST (LIST 'TYPE TYPE]
(COND
((NULL INSTREAM)
(\TFTP.SEND.ERROR TFTPCON 1 (CONCAT "Can't open file--" FILENAME))
NIL)
(T INSTREAM]
(* ;; "Mode is OK, and file is open for input. Open the TFTP stream back to the requestor")
(SETQ TFTPSTREAM (create STREAM
DEVICE ← DEVICE))
(replace (TFTPCON STREAM) of TFTPCON with TFTPSTREAM)
(replace (STREAM ACCESS) of TFTPSTREAM with 'OUTPUT)
(replace (TFTPSTREAM TFTPCON) of TFTPSTREAM with TFTPCON)
(* ;; "Use the incoming packet as the first data packet on the way out")
(\TFTP.SETUP UDP TFTPCON \TFTP.DATA NIL)
(* ;; "This is block number 1")
(UDP.APPEND.WORD UDP 1)
(add (fetch (UDP UDPLENGTH) of UDP)
512)
(\TFTP.INPUT.BUFFER TFTPSTREAM UDP)
(printout LOGSTREAM "TFTP Server: Sending " FILENAME T)
(COND
((NLSETQ (PROGN (COPYBYTES FILE TFTPSTREAM)
(\TFTP.GETNEXTBUFFER TFTPSTREAM 'WRITE T)
(\TFTP.CLOSEFILE TFTPSTREAM)))
(printout LOGSTREAM "TFTP Server: Done sending " FILENAME T))
(T (printout LOGSTREAM "TFTP Server: Failed to send " FILENAME T)))
(CLOSEF? FILE))
(T (printout LOGSTREAM "TFTP Server: Failed to send " FILENAME T)
(\RELEASE.ETHERPACKET UDP)
NIL)))
(* ;; "Remove connection from list.")
(LET (UDPSOCKET CONNECTION)
(SETQ UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
(SETQ CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON)
(fetch (UDP UDPDESTPORT) of UDPSOCKET)))
(SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS)))
RESULT])
)
(* ;; "User functions")
(DEFINEQ
(TFTP.SERVER
[LAMBDA (LOGSTREAM) (* MPL " 2-Jun-85 19:39")
(* * Create a new TFTP server. LOGSTREAM defaults to a popup window)
(ADD.PROCESS `(TFTP.SERVER.PROCESS %, LOGSTREAM) 'RESTARTABLE 'HARDRESET])
(TFTP.GET
[LAMBDA (FROM TO PARAMETERS) (* MPL " 2-Jun-85 17:15")
(LET ((EOLCONVENTION (CADR (FASSOC 'EOLCONVENTION PARAMETERS)))
(TYPE (FASSOC 'TYPE PARAMETERS))
(FROMNAME FROM)
(TONAME TO))
(RESETLST [SETQ TO (OPENSTREAM TO 'OUTPUT 'NEW NIL (COND
(TYPE (LIST TYPE]
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
(COND
((AND STREAM RESETSTATE)
(CLOSEF? STREAM)
(DELFILE (FULLNAME STREAM]
TO))
(SETQ FROM (\TFTP.OPENFILE FROM 'INPUT 'OLD PARAMETERS))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
(AND STREAM RESETSTATE (CLOSEF STREAM]
FROM))
(COND
(EOLCONVENTION (replace (STREAM EOLCONVENTION) of FROM with EOLCONVENTION)))
(COND
((AND FROM TO)
(COPYCHARS FROM TO)
(AND (OPENP FROM)
(CLOSEF FROM))
(FULLNAME (CLOSEF TO)))
(TO (ERRORX (LIST 9 FROMNAME)))
(FROM (ERRORX (LIST 9 TONAME])
(TFTP.PUT
[LAMBDA (FROM TO PARAMETERS) (* ; "Edited 15-Apr-87 20:55 by FS")
(LET ((EOLCONVENTION (CADR (FASSOC 'EOLCONVENTION PARAMETERS)))
(TYPE (FASSOC 'TYPE PARAMETERS)))
(* ;; "Why is TYPE not used anywhere?")
(RESETLST (SETQ FROM (OPENSTREAM FROM 'INPUT 'OLD))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
(AND RESETSTATE (CLOSEF STREAM]
FROM))
(SETQ TO (\TFTP.OPENFILE TO 'OUTPUT 'NEW PARAMETERS))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
(AND RESETSTATE (CLOSEF STREAM]
TO))
(COND
(EOLCONVENTION (replace (STREAM EOLCONVENTION) of TO with EOLCONVENTION)))
(COPYCHARS FROM TO)
(CLOSEF FROM)
(* ;; "Removed (FULLNAME (CLOSEF TO))")
(CLOSEF TO])
)
(* ;; "Tracing functions")
(DEFINEQ
(PRINTTFTP
[LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 14:00")
(DECLARE (GLOBALVARS TFTPOPCODES))
(PRINTCONSTANT (fetch (TFTP OPCODE) of TFTP)
TFTPOPCODES FILE "TFTP Opcode: ")
(SELECTC (fetch (TFTP OPCODE) of TFTP)
(\TFTP.RRQ (printout FILE " ")
(\TFTP.PRINT.REQUEST TFTP FILE))
(\TFTP.WRQ (printout FILE " ")
(\TFTP.PRINT.REQUEST TFTP FILE))
(\TFTP.ACK (printout FILE " ")
(\TFTP.PRINT.ACK TFTP FILE))
(\TFTP.DATA (printout FILE " ")
(\TFTP.PRINT.DATA TFTP FILE))
(\TFTP.ERROR (printout FILE " ")
(\TFTP.PRINT.ERROR TFTP FILE))
NIL)
(TERPRI FILE)
(TERPRI FILE])
(\TFTP.PRINT.ACK
[LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 12:48")
(printout FILE "Block #: " (fetch (TFTP BLOCK#) of TFTP)
T])
(\TFTP.PRINT.DATA
[LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 14:00")
(printout FILE "Block #: " (fetch (TFTP BLOCK#) of TFTP)
T)
(PRINTPACKETDATA (fetch (TFTP TFTPCONTENTS) of TFTP)
\TFTPOVLEN
'(CHARS 12 |...|)
(IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
(CONSTANT (IPLUS \TFTPOVLEN \UDPOVLEN])
(\TFTP.PRINT.ERROR
[LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 13:15")
(printout FILE "Error code: " (fetch (TFTP ERRORCODE) of TFTP)
T)
(PRINTPACKETDATA (fetch (TFTP TFTPCONTENTS) of TFTP)
0
'(CHARS |...|)
(IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
(CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN)))
FILE])
(\TFTP.PRINT.REQUEST
[LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 13:16")
(* * Try to start sending a file to the requestor as directed by the contents
of the received TFTP packet)
(LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
of TFTP)
I))
finally (RETURN (IDIFFERENCE I BYTESPERWORD]
(FILENAME (ALLOCSTRING FILENAMELENGTH))
[MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of TFTP)
I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD
FILENAMELENGTH
1]
(MODE (ALLOCSTRING MODELENGTH)))
(* * Read the filename out of the packet)
(\MOVEBYTES (fetch (TFTP TFTPBASE) of TFTP)
BYTESPERWORD
(fetch (STRINGP BASE) of FILENAME)
(fetch (STRINGP OFFST) of FILENAME)
FILENAMELENGTH)
(* * Read the mode out of the packet)
(\MOVEBYTES (fetch (TFTP TFTPBASE) of TFTP)
(IPLUS BYTESPERWORD FILENAMELENGTH 1)
(fetch (STRINGP BASE) of MODE)
(fetch (STRINGP OFFST) of MODE)
MODELENGTH)
(printout FILE (SELECTC (fetch (TFTP OPCODE) of TFTP)
(\TFTP.RRQ "Read request for ")
(\TFTP.WRQ "Write request for ")
(SHOULDNT))
FILENAME " in mode " MODE T])
)
(\TFTP.INIT)
(PUTPROPS TCPTFTP COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3943 28576 (\TFTP.ACKNOWLEDGE 3953 . 4632) (\TFTP.CLOSEFILE 4634 . 5329) (\TFTP.EOFP
5331 . 5688) (\TFTP.ERROR 5690 . 6466) (\TFTP.GETNEXTBUFFER 6468 . 19751) (\TFTP.INIT 19753 . 20842) (
\TFTP.INPUT.BUFFER 20844 . 22060) (\TFTP.OPENFILE 22062 . 27454) (\TFTP.READP 27456 . 27680) (
\TFTP.SEND.ERROR 27682 . 28177) (\TFTP.SETUP 28179 . 28574)) (28767 46380 (TFTP.SERVER.PROCESS 28777
. 32031) (\TFTP.GET.FILE 32033 . 39684) (\TFTP.SEND.FILE 39686 . 46378)) (46413 49364 (TFTP.SERVER
46423 . 46712) (TFTP.GET 46714 . 48255) (TFTP.PUT 48257 . 49362)) (49400 53466 (PRINTTFTP 49410 .
50239) (\TFTP.PRINT.ACK 50241 . 50442) (\TFTP.PRINT.DATA 50444 . 50883) (\TFTP.PRINT.ERROR 50885 .
51338) (\TFTP.PRINT.REQUEST 51340 . 53464)))))
STOP