;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.140
;;; Reason:
;;;  FTP and SMTP control connections are supposed to be Telnet streams.  They used to
;;;  simply ignore Telnet Escape sequences, but now respond appropriately to option
;;;  negotiations.
;;; Written 4-Dec-87 12:20:52 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.138, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.0, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8.



; From modified file DJ: L.NETWORK.IP-TCP.SERVER; FTP.LISP#80 at 4-Dec-87 12:21:06
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  "

(defun ftp-readline (stream &optional (getc #'(lambda (stream)
						(send stream :tyi))))
  (catch 'eof-tag
    (with-output-to-string (s)
      (do ((c (funcall getc stream) (funcall getc stream)))
	  ((eq c #o12))
	(cond ((null c)
	       (throw 'eof-tag nil))
	      ((= c telnet-iac)			;Telnet escape code
	       (unless (setq c (funcall getc stream))
		 (throw 'eof-tag nil))
	       (case (cadr (assoc c telnet:*telsyms* :test #'eq))
		 (telnet:do			;DO -- send a WONT
		  (unless (setq c (funcall getc stream))
		    (throw 'eof-tag nil))
		  (telnet:send-iac stream 'telnet:wont c))
		 (telnet:will			;WILL -- send a DONT
		  (unless (setq c (funcall getc stream))
		    (throw 'eof-tag nil))
		  (telnet:send-iac stream 'telnet:dont c))
		 ((telnet:dont telnet:wont)	;DONT or WONT -- ignore option
		  (unless (setq c (funcall getc stream))
		    (throw 'eof-tag nil)))))
	      ((= c #o15))			;Ignore CR -- wait for LF
	      (t
	       (send s :tyo c)))))))


))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; FTP.LISP#80 at 4-Dec-87 12:21:08
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  "


(defun ftp-cmdparse (state)
  (let ((cmdline (ftp-readline (ftpstate-ctrl-stream state)
			       #'(lambda (stream)
				   (loop
				     (when (process-wait-with-timeout "FTP command"
								      (and *ftp-server-timeout* (* 60. *ftp-server-timeout*))
								      #'(lambda (s)
									  (send s :listen))
								      stream)
				       ;;:listen returned non-NIL -- return what :tyi returns
				       (return (send stream :tyi)))
				     (unless (ftpstate-data-transfer-in-progress state)
				       ;;:listen returned NIL -- timeout.  If control connection idle, return NIL
				       (return nil))))))
	cmd arg)
    (cond ((not cmdline) (ftp-reply state 221 "You could at least say goodbye.") nil)
	  (t
	   (push cmdline (ftpstate-cmd-reply-history state))
	   (setq cmd (ftp-cmd-from-string cmdline))
	   (if (and (ftpstate-data-transfer-in-progress state) (not (eq cmd 'abor)))
	       (process-wait "wait for data transfer" 
			     #'(lambda nil (not (ftpstate-data-transfer-in-progress state)))))
	   (setf (ftpstate-current-cmd state) cmd)
	   (setq arg (ftp-first-cmd-arg cmdline (member cmd ftp-allow-spaces-in-arg-cmdlist :test #'eq)))

	   (cond ((and (ftpstate-next-cmd state)
		       (not (eq cmd 'rein))
		       (not (eq cmd 'quit))
		       (not (eq cmd (ftpstate-next-cmd state))))
		  (ftp-reply state 503 "Bad sequence of commands.")
		  (setf (ftpstate-next-cmd state) nil))

		 ((stringp cmd) (ftp-reply state 500 "~A command unrecognized" cmd))

		 ((member cmd ftp-unimplemented-cmdlist :test #'eq) (ftp-not-implemented state cmd))

		 ((and (not (ftpstate-logged-in-p state)) (member cmd ftp-logged-in-cmdlist :test #'eq))
		  (ftp-reply state 530 "Not logged in."))

		 ((and (or (not arg) (zerop (length arg)))
		       (member cmd ftp-require-arg-cmdlist :test #'eq))
		  (ftp-reply state 501 "Syntax error: missing argument."))

		 (t (funcall (get cmd 'ftp-server-handle) state arg cmdline)))
	   (not (eq cmd 'quit))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; SMTP.LISP#22 at 4-Dec-87 12:21:18
#10R TCP-APPLICATION#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; SMTP  "


(defun smtp-server-function (stream)
  (smtp-reply stream 220 "~A Simple Mail Transfer Service Ready"
	      (send si:local-host :name))
  (catch 'smtp-server-function
    (do ((*smtp-server-state* nil)
	 (si:user-id "SMTP_SERVER")
	 (string (ftp:ftp-readline stream)
		 (ftp:ftp-readline stream)))
	((null string))
      (smtp-server-command string stream))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#38 at 3-Dec-87 11:36:48
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(defun send-iac (stream &rest commands)
  (send stream :tyo (get 'iac 'telnet-sym))
  (dolist (char commands)
    (send stream :tyo (cond ((not (symbolp char)) char)
			    ((string-equal char "TELOPT_" :end1 7)
			     (get char 'telnet-opt))
			    ('else
			     (get char 'telnet-sym)))))
  (send stream :force-output))

))