;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 123.215 ;;; Reason: ;;; The :close method of a TCP stream now blocks, waiting for TCP to return ;;; :closed. This allows user to see when there is a send-timeout for the ;;; FIN. Such blocking does not occur if the :close mode is :normal, which ;;; the user specifies in order to do further receives. ;;; Server FTP now aborts the connection if the close fails, rather than ;;; not noticing it and leaving the user side hanging. ;;; FTP-ACCESS now closes the LISTENing data connection if the server ;;; indicates it will not be opening it. ;;; Written 11-Mar-88 13:34:41 by pld at site Gigamos Cambridge ;;; while running on Jack Flanders from band 2 ;;; with Experimental System 123.214, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Tape 21.1, microcode 1755, SDU Boot Tape 3.12, SDU ROM 8. ; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#288 at 11-Mar-88 13:35:05 #10R TCP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  " (defop (tcp-socket :close) (&optional (mode :discard)) ;;mode = nil or :discard -- throw away incoming data until FIN ;;mode = :normal -- allow further :receive's ;;mode = :abort or t -- abort connection (ecase mode ((:discard nil) (setq mode :discard)) ((:abort t) (setq mode :abort)) (:normal)) (cond ((null (tcp-user-state self))) ((eq (tcp-user-state self) :closed)) ((eq mode :abort) (send self :abort)) (t ;;Normal graceful close (with-lock ((tcp-user-lock self)) (tcp-log :close self) (cond ((setf (tcp-user-discard-p self) (eq mode :discard)) ;;Max out the window. Some (broken) implementations treat the window as a SIGNED number... (setf (RCV.WND self) (floor 65535 2)) (let ((saved-data (saved-but-unacknowledged-data self))) (when (plusp saved-data) ;;We have data saved but not given to user. Acknowledge it all. (setf (RCV.NXT self) (32-bit-plus (RCV.NXT self) saved-data)))) (do ((elt (pop-fifo (tcp-user-saved-packets self)) (pop-fifo (tcp-user-saved-packets self)))) ((null elt)) (free-tcp-buffer (rcv-buffer elt))) (let ((receives (fifo-as-list (tcp-user-receive-data self)))) (setf (tcp-user-receive-data self) nil) (setf (tcp-user-receive-data-length self) 0) (setf (tcp-user-receive-data-offset self) 0) (push-fifo `(:close ,(mapcar #'rcv-buffer receives)) (tcp-user-packet-list self)))) (t (push-fifo '(:close) (tcp-user-packet-list self)))) (ecase (tcp-user-state self) (:CLOSED ;;(error "connection does not exist") (push-fifo '(:closed) (tcp-user-packet-list self)) nil) ((:LISTEN :SYN-SENT) (tcp-stat-incf self (if (eq (tcp-user-state self) :listen) in-connection-aborts out-connection-aborts)) (flush-tcp-socket self) (push-fifo '(:closed) (tcp-user-packet-list self)) t) (:SYN-RECEIVED (setf (tcp-user-closed-p self) t) (setf (tcp-user-fin-needed-p self) t) (when (fifo-empty-p (tcp-user-send-data self)) (change-state self :FIN-WAIT-1) (send-tcp-packets self)) t) (:ESTABLISHED (setf (tcp-user-closed-p self) t) (setf (tcp-user-fin-needed-p self) t) (change-state self :FIN-WAIT-1) (send-tcp-packets self) t) (:CLOSE-WAIT (setf (tcp-user-closed-p self) t) (setf (tcp-user-fin-needed-p self) t) (change-state self :CLOSING) (send-tcp-packets self) t) ((:FIN-WAIT-1 :FIN-WAIT-2 :CLOSING :LAST-ACK :TIME-WAIT) ;;(error "connection closing") nil)))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#52 at 11-Mar-88 13:36:39 #10R TCP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  " (defmethod (tcp-stream-mixin :close) (&optional mode) (when open (send self :force-output) (setq open nil) (apply socket :close (ncons mode)) (unless (eq mode :normal) (loop (case (send self :handle-replies) ((:reset :unreachable :closed) (return)) (:timeout (send self :send-timeout))))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#52 at 11-Mar-88 13:36:46 #10R TCP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  " (defmethod (tcp-stream-mixin :handle-replies) (&optional no-hang-p) (loop (cond ((send socket :listen) ;Activity on the socket (let ((item (send socket :read-data))) (case (first item) (:open (send self :build-buffers) (return :open)) (:write-reply (incf bytes-written (fill-pointer (second item))) (send self :write-reply (second item)) (return :write-reply)) (:data (let ((length (fill-pointer (second item))) (offset (fourth item))) (when offset ;Remember last known offset of urgent data (setq urgent-offset (+ bytes-read offset 1)) (setq urgent-input t)) (incf bytes-read length) (when (eq (third item) :eof) (setq closing t)) (send self :read-reply (second item) urgent-offset)) (return :read-reply)) (:urgent ;should signal this somehow... (setq urgent-input t)) (:closing ;Remote side has closed (setq closing t) (return :remote-close)) (:reset (setq closing t) (setq open nil) (dolist (b (third item)) (send self :write-reply b)) ;;(cerror "Continue, treating as end-of-file" "Connection reset remotely") (return :reset)) (:close ;Socket closed out from under us (setq closing t) (setq open nil) ;;(cerror "Continue, treating as end-of-file" "Connection reset locally") (return :local-close)) ((:network-unreachable :host-unreachable :protocol-unreachable :port-unreachable) (setq closing t) (setq open nil) (send socket :abort) (return :unreachable)) (:timeout (setq timeout t) (return :timeout)) (:closed (return :closed)) (otherwise ;;Ignore it )))) (no-hang-p ;No activity and no-hang (return nil)) (t ;No activity -- wait (send self :wait-for-reply))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#43 at 11-Mar-88 13:37:27 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defun close-dataconn (&optional (getreply t)) (when *data* (close *data*) (setq *data* nil)) (and getreply *connected* (getreply nil))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#43 at 11-Mar-88 13:40:16 #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 :close-dataconn) (&optional (normal t)) (ftp:close-dataconn normal)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#43 at 11-Mar-88 13:40:44 #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-file-stream-mixin :after :close) (&optional abortp) (unless (eq status :closed) (send actual :close abortp) (send host-unit :remove-file-stream self) (send host-unit :close-dataconn) (send host-unit :free) (setq status :closed))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#43 at 11-Mar-88 13:41:01 #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-access :open) (file pathname &key &optional (direction :input) (characters t) (byte-size :default) (error t) if-exists ; if-does-not-exist raw-directory-list probe-directory-list &allow-other-keys &aux probe-stream) (cond ((memq direction '(nil :probe)) (make-instance 'ftp-probe-stream :truename nil :pathname pathname :host host :raw-data (and (ftp-directory-line-parserp host t) (with-output-to-string (s) (with-open-file (d file :raw-directory-list t :probe-directory-list t :error error) (when (streamp d) (stream-copy-until-eof d s))))))) ('else (when (and (memq direction *ftp-probe-before-open-directions*) (not raw-directory-list) (or (eq *ftp-probe-before-open-p* t) (memq (send host :system-type) *ftp-probe-before-open-p*) (get host :ftp-probe-before-open-p))) (setq probe-stream (open file :direction nil :error error)) (when (and (eq direction :output) (memq (send file :version) '(nil :newest))) (cond ((not (send probe-stream :truename)) (send probe-stream :set-truename (send file :new-version 1))) ((numberp (send (send probe-stream :truename) :version)) ;; kludge-a-rama. The *FTP-PROBE-BEFORE-OPEN-P* is useful ;; if the host cant take so many simultaneous servers ;; as would be created if we probe *after* the opening of ;; the file data connection. The most sensible solution to ;; all of this is to use another file protocol. (send probe-stream :set-truename (send (send probe-stream :truename) :new-version (1+ (send (send probe-stream :truename) :version)))))) (when (not (plist probe-stream)) (setf (plist probe-stream) `(:creation-date ,(time:get-universal-time)))))) (handling-file-errors (error) (allocating-host-unit (unit) (let ((command nil) (buffers nil) (optimistic nil)) (when probe-directory-list (setq buffers 1) (setq optimistic t)) (cond (raw-directory-list (setq command "LIST ~A")) ((eq direction :output) (setq command (caseq if-exists (:append "APPE ~A") (t "STOR ~A")))) ((eq direction :input) (setq command "RETR ~A"))) (and (eq byte-size :DEFAULT) (eq characters t) (setq byte-size 8)) (cond ((and (eq characters :DEFAULT) (eq byte-size :DEFAULT)) ;; almost no way of getting this information ;; unix uses magic numbers, on VMS maybe character if ;; record format variable length CR. ;; for now kludge it so that at least load works on ;; qfasl files. (multiple-value (characters byte-size) (kludge-ftp-characterp file pathname))) ((eq byte-size :default) (setq byte-size 8))) (cond ((not characters) (send unit :setbinary byte-size)) ((eq (send host :system-type) :lispm) (send unit :setbinary 8)) ('else ;; in fact if the host is a unix host then ;; binary mode with our own easier-to-do translation ;; would be better than forcing kludgy ascii ;; translation to happen on both hosts. (send unit :setascii))) (ftp-access-operation file unit :initconn direction buffers optimistic) (multiple-value-bind (c code) (send unit :command command (fixup-ftp-string-for-host (send file :string-for-host) file)) (cond ((= c (tcp-application:sym ftp:PRELIM)) (ftp-access-operation file unit :dataconn file pathname direction byte-size raw-directory-list probe-stream)) ((and (= code 530.) (progn (send unit :login unit t host) ;; some hosts forget about the PORT ;; command after a USER command is ;; given, so give it again. (ftp-access-operation file unit :initconn direction buffers optimistic) (= (tcp-application:sym ftp:PRELIM) (send unit :command command (send file :string-for-host))))) (ftp-access-operation file unit :dataconn file pathname direction byte-size raw-directory-list probe-stream)) ('else (send unit :close-dataconn nil) (send unit :ftp-error "Access error" file)))))))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.SERVER; FTP.LISP#82 at 11-Mar-88 14:03:29 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  " (defun ftp-cleanup-data-connection (state kill-process-p) (if (ftpstate-data-stream state) (global:condition-case-if ftp-catch-errors (err) (send (ftpstate-data-stream state) :close) (error (send (ftpstate-data-stream state) :abort)))) (if kill-process-p (if (ftpstate-data-transfer-process state) (kill-subprocess (ftpstate-data-transfer-process state)))) (setf (ftpstate-data-stream state) nil) (setf (ftpstate-data-my-address state) nil) (setf (ftpstate-data-his-address state) :default) (setf (ftpstate-data-connection-method state) :active) (setf (ftpstate-data-transfer-in-progress state) nil) (setf (ftpstate-data-transfer-process state) nil)) ))