;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.70
;;; Reason:
;;;  ftp:*cin* and ftp:*cout* are stupid: replace with single variable: ftp:*control*
;;; Written 23-Oct-87 16:13:03 by pld at site LMI Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.69, Experimental Local-File 73.0, Experimental FILE-Server 22.0, 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.USER; FTP.LISP#28 at 23-Oct-87 16:13:13
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "

(defvar *control*)

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#28 at 23-Oct-87 16:13:21
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun hookup (host port &optional (keyword "FTP Control Connection"))
  (setq *remote-hostname* (if (numberp host)
			    (format nil "~X" host)
			  (string host)))
  (setq *control* (open (string-append "TCP-HOST:" host "." port)
		  :keyword keyword))
  (if *verbose* (format t "~&Connected to ~S~%" host))
  (getreply nil))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#28 at 23-Oct-87 16:13:26
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun getreply-line (expecteof)
  (labels ((peekc ()
		  (or (and *control* (send *control* :tyipeek))
		      (if expecteof nil (lostpeer))))
	   (getc ()
		 (let ((c (and *control* (send *control* :tyi))))
		   (or expecteof c (lostpeer))
		   (or (not c) (= c (sym lf))
		       (history-record-char (if (= c (sym cr)) #\return c)))
		   (cond ((or (not c) (not *verbose*)))
			 ((= c (sym lf)))
			 ((= c (sym cr))
			  (terpri))
			 ('else
			  (write-char c)))
		   c)))
    (prog (code j c weight continuationp)
	  (setq code 0 j 0)
       get-code
	  (cond ((not (= j 3)))
		((eq #\- (peekc))
		 (setq continuationp t)
		 (getc)
		 (go get-crlf))
		('else
		 (go get-crlf)))
	  (setq c (getc))
	  (cond ((null c)
		 (return (values -1 nil)))
		((null (setq weight (digit-char-p c)))
		 (setq code nil)
		 (go get-crlf))
		('else
		 (setq code (+ (* code 10) weight))
		 (incf j)
		 (go get-code)))
       get-crlf
	  (setq c (getc))
	  (cond ((null c)
		 (return (values code continuationp)))
		((= c (sym cr))
		 (setq c (getc))
		 (or (eq c (sym lf))
		     (not *debug*)
		     (error "expecting LF after CR but got: ~@C" c))
		 (return (values code continuationp)))
		('else
		 (go get-crlf))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#28 at 23-Oct-87 16:13:30
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun lostpeer ()
  (when *connected*
    (when *control*
      (close *control*)
      (setq *control* nil))
    (when *data*
      (close *data*)
      (setq *data* nil))
    (setq *connected* nil)
    (let ((s (last-reply))
	  (bogo "599 server randomly died, lost connection, did not print this"))
      (when s
	(setf (fill-pointer s) (length bogo))
	(copy-array-contents bogo s)))
    (throw 'lostpeer (values (sym error) 599))))


))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#28 at 23-Oct-87 16:13:33
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun command-1 (command-string)
  (if *debug* (format t "~&---> ~A~%" command-string))
  (unless *control*
    (and *debug* (format *error-output* "~&No control connection for command~%"))
    (return-from command-1 0))
  (push (string-append "" command-string) *history*)
  (do ((j 0 (1+ j))
       (n (length command-string)))
      ((= j n))
    (send *control* :tyo (aref command-string j)))
  
  (send *control* :tyo (sym cr))
  (send *control* :tyo (sym lf))
  (send *control* :force-output)
  (multiple-value-prog1
    (getreply (if (string-equal command-string "QUIT")
		  (if *ignore-reply-from-quit*
		      (return-from command-1 nil)
		    t)))
    ;; amoung other things this may free a fixed-resource
    ;; i/o buffer.
    (and *control* (send *control* :clear-input))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#28 at 23-Oct-87 16:13:37
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun initconn (direction)
  (when *data*
    (close *data*)
    (setq *data* nil))
  (let ((addr nil)
	(port nil)
	(result nil))
    (setq *data* (open (format nil
			     "TCP-HOST:~D.FTP-DATA~:[#~D~;~]"
			     (send *control* :remote-address)
			     *sendport*
			     (send *control* :local-port))
		     :direction direction
		     :input-buffers 16
		     :output-buffers 16
		     :optimistic nil
		     :keyword "FTP Data Connection"
		     :connect nil))
    (when *sendport*
      (setq addr (send *data* :local-address))
      (setq port (send *data* :local-port))
      (setq result (command "PORT ~D,~D,~D,~D,~D,~D"
			    (ldb (byte 8 24) addr)
			    (ldb (byte 8 16) addr)
			    (ldb (byte 8 8) addr)
			    (ldb (byte 8 0) addr)
			    (ldb (byte 8 8) port)
			    (ldb (byte 8 0) port)))
	(if (= result (sym error))
	    (let ((*sendport* nil))
	      (initconn direction))
	  (not (= result (sym complete)))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#28 at 23-Oct-87 16:13:39
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defcmd cmd-close ()
  "terminate ftp session"
  (if (not *connected*)
      (return-from cmd-close nil))
  (command "QUIT")
  (when *control*
    (close *control*)
    (setq *control* nil))
  (when *data*
    (close *data*)
    (setq *data* nil))
  (setq *connected* nil))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#28 at 23-Oct-87 16:13:42
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "

(defun ftp (&optional remote-hostname
	    &key
	    (auto-login t)
	    (trace t)
	    (hash nil)
	    (sendport t)
	    (verbose t)
	    (debug nil)
	    (bell nil)
	    (glob t)
	    (prompt t)
	    (type 'ascii)
	    (struct 'file)
	    (form 'non-print)
	    (mode 'stream)
	    (bytesize 8.)
	    user pass acct)

  (let ((*print-radix* nil)			;prevent garbage in numbers printed by princ and prin1
	(*history* nil)
	(*connected* nil)
	(*control* nil)
	(*data* nil)
	(*remote-hostname* remote-hostname)
	(*auto-login* auto-login)
	(*trace* trace)
	(*hash* hash)
	(*sendport* sendport)
	(*verbose* verbose)
	(*debug* debug)
	(*bell* bell)
	(*glob* glob)
	(*prompt* prompt)
	(*type* type)
	(*struct* struct)
	(*form* form)
	(*mode* mode)
	(*bytesize* bytesize)
	(*user* user)
	(*pass* pass)
	(*acct* acct))

    (when *remote-hostname*
      (cmd-open *remote-hostname*))
    (catch 'quit
      (unwind-protect
	  (global:error-restart ((error) "Return to FTP Command Loop.")
	    (loop
	      (execute-ftp-command-list
		(parse-line-into-list
		  (global:prompt-and-read :string-or-nil "~&ftp> ")))))
	(cmd-close)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#29 at 23-Oct-87 16:14:56
#10R FILE-SYSTEM#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


(defflavor ftp-host-unit
	   ((ftp:*auto-login* nil)
	    (ftp:*trace* *ftp-host-unit-debug*)
	    (ftp:*hash* *ftp-host-unit-debug*)
	    (ftp:*sendport* t)
	    (ftp:*verbose* *ftp-host-unit-debug*)
	    (ftp:*debug* *ftp-host-unit-debug*)
	    (ftp:*bell* nil)
	    (ftp:*glob* t)
	    (ftp:*prompt* nil)
	    ftp:(*type* 'ascii)
	    ftp:(*struct* 'file)
	    ftp:(*form* 'non-print)
	    ftp:(*mode* 'stream)
	    (ftp:*bytesize* 8.)
	    (ftp:*user* nil)
	    (ftp:*pass* nil)
	    (ftp:*acct* nil)
	    (ftp:*history* nil)
	    (ftp:*connected* nil)
	    (ftp:*remote-hostname* nil)
	    (ftp:*control* nil)
	    (ftp:*data* nil)
	    (reserve-lock (LIST NIL))
	    (file-stream nil)
	    (working-directory))
	   (basic-host-unit)
  :special-instance-variables)

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#29 at 23-Oct-87 16:15:03
#10R FILE-SYSTEM#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


(defmethod (ftp-host-unit :real-login) (login-p uname-host)
  (lock-host-unit (self)
    (cond (login-p
	   (do ((need-password? nil t))
	       (nil)
	     (multiple-value-bind (username password)
		 (fs:determine-user-id-and-password uname-host host need-password?)
	       (when (ftp:cmd-user username password)
		 (setq ftp:*user* nil)		;Don't leave these visible in host unit
		 (setq ftp:*pass* nil)
		 (setq ftp:*acct* nil)
		 (return))
	       (when need-password?
		 ;; The password we used must have been wrong, so forget
		 ;; it and force the system to prompt for a new one.
		 (forget-password username host)))
	     ;; Since this password is wrong, flush it
	     (when (get host :extra-reply-after-failed-login)
	       ;; the 4.2BSD server host we have sends an extra reply
	       ;; here. The Unix User FTP attempts to flush such extra input
	       ;; received after a getreply, but even that fails because
	       ;; of timing screws, doing a :LISTEN and sleeping
	       ;; to see if some losing server is going to send extra
	       ;; garbage just doesnt make sense.
	       (sleep 1 "unix wait")
	       (when (send ftp:*control* :listen)
		 (send ftp:*control* :tyi)
		 (send ftp:*control* :clear-input)))
	     (unless catch-login-problems-p
	       (send self :ftp-error "trying to login" nil))))
	  ((send self :open-control-connection-p)
	   (ftp:cmd-close)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#29 at 23-Oct-87 16:15:06
#10R FILE-SYSTEM#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


(defmethod (ftp-host-unit :setup-control-connection) ()
  (unless (and ftp:*control* (send ftp:*control* :remote-address))
    (setq ftp:*connected* nil))
  (cond ((not ftp:*connected*)
	 (ftp:cmd-open (send host :name))
	 (send self :real-login t host)))
  t)

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; SMTP.LISP#16 at 23-Oct-87 16:16:14
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; SMTP  "


(defflavor smtp-user
	   ((*trace* nil)
	    (*hash* nil)
	    (*verbose* nil)
	    (*debug* nil)
	    (*connected* nil)
	    (*remote-hostname* nil)
	    (*control* nil)
	    (*data* nil)
	    (*history* nil))
	   ()
  :special-instance-variables)


#|

                     Example of the SMTP Procedure

         This SMTP example shows mail sent by Smith at host Alpha.ARPA,
         to Jones, Green, and Brown at host Beta.ARPA.  Here we assume
         that host Alpha contacts host Beta directly.

            S: MAIL FROM:<Smith@Alpha.ARPA>
            R: 250 OK

            S: RCPT TO:<Jones@Beta.ARPA>
            R: 250 OK

            S: RCPT TO:<Green@Beta.ARPA>
            R: 550 No such user here

            S: RCPT TO:<Brown@Beta.ARPA>
            R: 250 OK

            S: DATA
            R: 354 Start mail input; end with <CRLF>.<CRLF>
            S: Blah blah blah...
            S: ...etc. etc. etc.
            S: <CRLF>.<CRLF>
            R: 250 OK

|#

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; SMTP.LISP#16 at 23-Oct-87 16:16:17
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; SMTP  "


(defmethod (smtp-user :close) (&rest ignored)
  (unwind-protect
      (cmd-close)
    (and *control* (close *control*))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; SMTP.LISP#16 at 23-Oct-87 16:16:19
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; SMTP  "


(defmethod (smtp-user :message-line) (x)
  (cond ((string-equal x ".")
	 (princ ".." *control*))
	('else
	 (princ x *control*)))
  (send *control* :tyo (sym cr))
  (send *control* :tyo (sym lf)))


))

; From modified file DJ: L.NETWORK.IP-TCP.USER; SMTP.LISP#16 at 23-Oct-87 16:16:20
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; SMTP  "


(defmethod (smtp-user :end-message) ()
  (send *control* :tyo (sym cr))
  (send *control* :tyo (sym lf))
  (send *control* :tyo #\.)
  (send *control* :tyo (sym cr))
  (send *control* :tyo (sym lf))
  (send *control* :force-output)
  (getreply nil))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; SMTP.LISP#16 at 23-Oct-87 16:16:23
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; SMTP  "


(defmethod (smtp-user :data-stream) (stream)
  (global:stream-copy-until-eof
    stream 
    (make-smtp-data-stream (ftp:make-ascii-translating-output-stream *control*))))


))

; From modified file DJ: L.NETWORK.IP-TCP.USER; SMTP.LISP#16 at 23-Oct-87 16:16:24
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; SMTP  "


(defmethod (smtp-user :funcall-on-data-stream) (f &rest l)
  (apply f
	 (make-smtp-data-stream (ftp:make-ascii-translating-output-stream *control*))
	 l))

))

; From modified file DJ: L.WINDOW; PEEKFS.LISP#11 at 23-Oct-87 16:17:37
#8R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: WINDOW; PEEKFS  "

(defun peek-ftp-host-unit (unit &optional (indent 2))
  "Generate a scroll item describing a host unit"
  (list ()
    (tv:scroll-parse-item ':mouse
			  `(nil :menu-choose
				("Host-unit operations"
				 ("Reset" :eval (funcall thisunit ':reset)
				  :documentation
				  "Click left to close this connection")
				 ("History" :eval (send tv:selected-window :force-kbd-input `(:eval (ftp-history ,thisunit)))
				  :documentation
				  "Show command history for this unit")
				 ("Inspect" :eval (send tv:selected-window :force-kbd-input `(inspect ,thisunit))
				  :documentation
				  "Click left to INSPECT this host-unit.")
				 ("Describe" :eval (send tv:selected-window :force-kbd-input `(describe ,thisunit))
				  :documentation
				  "Click left to DESCRIBE this host-unit."))
				:documentation
				"Menu of things to do to this host-unit."
				:bindings
				((thisunit ',unit)
				 (typwin ',(funcall self ':typeout-window))))
			  (format nil "~V@THost unit for ~A"
				  indent (send unit :host))
			  `(:FUNCTION ,#'(LAMBDA (UNIT)
					   (let* ((control (symeval-in-instance unit 'ftp:*control*))
						  (control-socket (and control (send control :socket)))
						  (data (symeval-in-instance unit 'ftp:*data*))
						  (data-socket (and data (send data :socket))))
					     (format nil
						   " with ~A control connection and ~A data connection"
						   (if control-socket
						       (tcp:tcp-user-state control-socket)
						     :non-existent)
						   (if data-socket
						       (tcp:tcp-user-state data-socket)
						     :non-existent)
						   )))
				      (,UNIT)))
    (tv:scroll-maintain-list `(lambda () (send ',unit :open-streams))
			     `(lambda (stream)
				(funcall stream ':peek-file-system (+ 2 ,indent))))
    ))

))