;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.77
;;; Reason:
;;;  Miscellaneous User and Server FTP cleanups
;;;    - Random errors return :report-string in the FTP reply
;;;    - User FTP was not properly skipping continuations
;;;    - FTP Server Help now puts continuations on all line
;;; Written 27-Oct-87 22:44:29 by pld at site LMI Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.76, 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.SERVER; FTP.LISP#68 at 27-Oct-87 22:51:26
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  "


(defun ftp-retrieve-1 (state pn directory-p &aux os is)
  (setq is (cond (directory-p
		  (or (send pn :name) (setq pn (send pn :new-name :wild)))
		  (setq pn (fs:merge-pathname-components
			     pn
			     (ftpstate-pn-defaults state)
			     :default-type :wild
			     :default-version :wild))
		  (cond ((member directory-p '(:name-list :directory-list) :test #'eq)
			 (fs:directory-list-stream pn))
			(t (zwei:directory-input-stream pn :deleted))))
		 (t (open pn
			  :characters (eq (ftpstate-transfer-type state) :ascii)
			  :byte-size (ftpstate-byte-size state)))))
  (setq os (get-ftp-data-connection state
				    (send is :send-if-handles :truename)
				    (send is :send-if-handles :length)
				    :output))
  (if (streamp os)
      (ftp-send-data state is os directory-p)
    (ftp-reply state 425 "Can't open data connection")))


))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; FTP.LISP#68 at 27-Oct-87 22:51:46
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  "


(defun ftp-store-1 (state pn mode &aux os is)
  "Write a file to the local TCP host (modulo chaosnet file servers)
    Mode can be any keyword acceptable for the :IF-EXISTS option to OPEN."
  (setq os (open pn
		 :characters (eq (ftpstate-transfer-type state) :ascii)
		 :byte-size (ftpstate-byte-size state)
		 :if-exists mode
		 
;;; not used, so commented out for release 3.0, should implement this
;;; in our local file system then use it.
;;;	:ESTIMATED-LENGTH (PROG1 (FTPSTATE-ESTIMATED-LENGTH STATE)  
;;;			      (SETF (FTPSTATE-ESTIMATED-LENGTH STATE) NIL))
		 
		 :direction :output))
  (setq is (get-ftp-data-connection state
				    (send os :send-if-handles :truename)
				    nil
				    :input))
  (if (streamp is) 
      (ftp-receive-data state is os)
    (ftp-reply state 425 "Can't open data connection")))



))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; FTP.LISP#68 at 27-Oct-87 22:52:46
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  "


(defun get-ftp-data-connection (state name size mode)
  ;; Establish connection if necessary
  (when (eq (ftpstate-data-his-address state) :default)
    (setf (ftpstate-data-his-address state) (send (ftpstate-ctrl-stream state) :remote-address))
    (setf (ftpstate-data-his-port state) (send (ftpstate-ctrl-stream state) :remote-port)))

  (let ((success (or (eq (ftpstate-data-connection-method state) :passive)
		     (make-ftp-data-connection state name size mode))))

    ;; reset defaults for next data transfer
    (setf (ftpstate-data-connection-method state) :active) 
    (setf (ftpstate-data-his-address state) :default)

    (and success (ftpstate-data-stream state))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; FTP.LISP#68 at 27-Oct-87 22:54:06
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  "

(defun ftp-receive-data-function (state instream outstream &aux success)
  "Transfer the contents of net instream to local outstream"
  (global:condition-case-if ftp-catch-errors (err)
      (case (ftpstate-transfer-type state)
	(:ascii
	 (let ((ftp:*hash* nil)) 
	   (declare (special ftp:*hash*))
	   (with-open-stream (is (ftp:make-ascii-translating-input-stream instream))
	     (global:stream-copy-until-eof is outstream)))
	 (setq success t))
	((:image :logical-byte-size)
	 (case (ftpstate-byte-size state)
	   (8
	    (global:stream-copy-until-eof instream outstream))
	   (16
	    (let ((trans (make-8b-to-16b-translating-output-stream outstream)))
	      (global:stream-copy-until-eof instream trans)
	      (send trans :force-output))))
	 (setq success t))
	(otherwise (error "Bad transfer type in FTPSTATE.")))
    (fs:file-error (ftp-file-error-reply state err) nil)
    (error (ftp-reply state 451 "Local error in processing: ~A." (send err :report-string)) nil))
  (close outstream)
  (ftp-cleanup-data-connection state nil)
  (setf (ftpstate-data-transfer-in-progress state) nil)
  (if success (ftp-reply state 226 "Transfer complete.")))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; FTP.LISP#68 at 27-Oct-87 22:57:59
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  "

(defun ftp-send-data-function (state instream outstream directory-p)
  (let ((translating-outstream
	  (case (ftpstate-transfer-type state)
	    (:ascii
	     (ftp:make-ascii-translating-output-stream outstream nil))
	    ((:image :logical-byte-size)
	     (case (ftpstate-byte-size state)
	       (8 outstream)
	       (16 (make-16b-to-8b-translating-output-stream outstream))))
	    (t
	     nil)))
	(completedp nil))
    (unwind-protect
	(if (not translating-outstream)
	    (ftp-reply state 504 "Unimplemented type ~A." (ftpstate-transfer-type state))
	  (global:condition-case-if ftp-catch-errors (err)
	      (progn (cond ((not directory-p)
			    (global:stream-copy-until-eof instream translating-outstream)
			    (or (eq translating-outstream outstream)
				(send translating-outstream :force-output)))
			   ((eq directory-p t)
			    (do ((entry))
				((null (setq entry (send instream :line-in))))
			      (send translating-outstream :string-out entry)
			      (terpri translating-outstream)))
			   ((eq directory-p :directory-list)
			    (do ((entry))
				((null (setq entry (send instream :entry))))
			      (prin1 entry translating-outstream)
			      (terpri translating-outstream)))
			   ((eq directory-p :name-list)
			    (send instream :entry) ;; GET RID OF DISK-SPACE-DESCRIPTION
			    (do ((entry))
				((null (setq entry (send instream :entry))))
			      (send translating-outstream :string-out
				    (send (car entry) :string-for-printing))
			      (terpri translating-outstream))))
		     (setq completedp t))
	    (fs:file-error (ftp-file-error-reply state err))
	    (error (ftp-reply state 451 "Local error in processing: ~A." (send err :report-string)) nil)))
      (close instream)
      (if completedp (send outstream :force-output))
      (ftp-cleanup-data-connection state nil)
      (setf (ftpstate-data-transfer-in-progress state) nil)
      (if completedp (ftp-reply state 226 "Transfer complete")))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#32 at 28-Oct-87 00:01:49
#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 #\- (int-char (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.SERVER; FTP.LISP#68 at 28-Oct-87 00:08:24
#10R FTP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  "

(defun ftp-help (state cmdstring &aux cmd)
  (cond (cmdstring
	 (setq cmd (ftp-cmd-from-string cmdstring))
	 (if (symbolp cmd)
	     (if (member cmd ftp-unimplemented-cmdlist :test #'eq)
		 (ftp-reply state 214 "~A unimplemented." cmd)
	       (ftp-reply state 214 "Syntax: ~A~A." cmd (get cmd 'ftp-help)))
	   (ftp-reply state 504 "Unknown command ~A." cmd)))
	(t
	 (ftp-reply state nil 
		    "214-The following commands are recognized (* =>'s unimplemented).")
	 
	 (zl:loop for l on ftp-cmdlist by #'(lambda (l) (nthcdr 6 l))
		  while l
		  do (ftp-reply state nil
				(apply #'string-append
				       "214-"
				       (zl:loop for x in l
						for count from 1 to 6
						collect (format nil "~A~4A" 
								(if (member x ftp-unimplemented-cmdlist
									      :test #'eq)
								    " *"
								  "  ")
								x))))
		  finally (ftp-reply state 214 "Direct comments to ~A."
				     (or (global:get-site-option :ftp-server-administrator)
					 *ftp-server-administrator*))))))

))