;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.131
;;; Reason:
;;;  Make TCP Urgent mode work for tcp-streams.
;;;    - TCP wasn't setting urgent bit for a single byte of data
;;;    - Netstat wasn't displaying SND.UP and RCV.UP usefully
;;;    - tcp-stream now lets you :set-urgent-output to specify that outgoing data is Urgent.
;;;    - tcp-stream now lets you :urgent-input to see if unread Urgent data exists.
;;; Written 30-Nov-87 17:03:06 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.129, 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.KERNEL; TCP.LISP#283 at 30-Nov-87 17:03:19
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "


(defun build-tcp-packet (tp)
  "Builds and returns a TCP packet for TCP connection tp"
  (declare (values buffer-list byte-count))
  (let* ((header (get-tcp-header))
	 (buffers (ncons header))
	 (data-to-send 0)
	 (ISS (ISS tp))
	 (SND.UNA (SND.UNA tp))
	 (SND.NXT (SND.NXT tp))
	 (SND.UP (SND.UP tp)))
    (setf (tcp-source-port header) (tcp-user-local-port tp))
    (setf (tcp-destination-port header) (tcp-user-remote-port tp))
    (setf (tcp-sequence-number header) SND.NXT)
    (setf (tcp-ack-number header) (RCV.NXT tp))
    (setf (tcp-reserved-1 header) 0)
    (setf (tcp-reserved-2 header) 0)
    (setf (tcp-flags header) 0)
    (cond ((= ISS SND.NXT)
	   (setf (tcp-data-offset header) 6)
	   (setf (fill-pointer header) 24)
	   (setf (tcp-syn-bit header) 1)
	   (setf (aref header 20) tcp-opt-mss)
	   (setf (aref header 21) 4)
	   (let ((mss (tcp-user-interface-mss tp)))
	     (setf (aref header 22) (ldb (byte 8 8) mss))
	     (setf (aref header 23) (ldb (byte 8 0) mss))))
	  (t
	   (setf (tcp-data-offset header) 5)
	   (setf (fill-pointer header) 20)))
    
    (unless (member (tcp-user-state tp) '(:CLOSED :LISTEN :SYN-SENT))
      (setf (tcp-ack-bit header) 1))
    
    (setf (tcp-window header) (RCV.WND tp))
    
    (cond ((and SND.UP (32-bit->= SND.UP SND.NXT))
	   (setf (tcp-urg-bit header) 1)
	   (setf (tcp-urgent-pointer header) (32-bit-minus SND.UP SND.NXT)))
	  (t
	   (setf (tcp-urgent-pointer header) 0)))
    
    ;; Add user data to list of buffers
    (setq data-to-send (min (- (tcp-user-send-data-length tp) (tcp-user-send-data-offset tp))	;user data
			    (tcp-user-remote-mss tp)	;remote end's max segment
			    (tcp-user-interface-mss tp)))	;max data in int-pkt
    (unless (eq (tcp-user-state tp) :SYN-SENT)
      (setq data-to-send (min (- (SND.WND tp)
				 (32-bit-minus SND.NXT SND.UNA))
			      data-to-send)))
    (when (plusp data-to-send)
      (do ((left data-to-send)
	   (current-offset 0)
	   (start-offset (- (tcp-user-send-data-offset tp)	;sent but unACKed
			    (if (= ISS SND.UNA) 1 0)))	        ;but don't count SYN
	   (list (fifo-as-list (tcp-user-send-data tp)) (cdr list)))
	  ((or (null list) (not (plusp left)))
	   (unless (zerop left)
	     (cerror "continue" "Not enough data in send list")))
	(let ((length (length (first list))))
	  (cond ((> start-offset current-offset)
		 ;;At least front of this buffer gets skipped...
		 (let ((skip (- start-offset current-offset)))
		   (unless (>= skip length)
		     (push (make-array (min (- length skip) left)
				       :element-type '(unsigned-byte 8)
				       :displaced-to (first list)
				       :displaced-index-offset skip)
			   buffers)
		     (decf left (length (first buffers))))))
		((> length left)
		 ;;Tail of this buffer is skipped...
		 (push (make-array left
				   :element-type '(unsigned-byte 8)
				   :displaced-to (first list))
		       buffers)
		 (return))
		(t
		 ;;Entire buffer included
		 (push (first list) buffers)
		 (decf left length)))
	  (incf current-offset length)))
      (setq buffers (nreverse buffers))
      
      ;;If this buffer includes PUSHed data, set the PUSH bit
      (when (and (tcp-user-push-sequence-number tp)
		 (32-bit-< (tcp-user-push-sequence-number tp)
			   (32-bit-plus SND.NXT data-to-send)))
	(setf (tcp-psh-bit header) 1)))
    
    ;;Have we included the last data byte the user's given us?
    (when (= (+ data-to-send (tcp-user-send-data-offset tp))
	     (tcp-user-send-data-length tp))
      (when (tcp-user-auto-push tp)
	;; In auto-push mode, set the PUSH bit
	(setf (tcp-psh-bit header) 1))
      ;; Set the FIN bit too if the user has closed the connection
      (when (tcp-user-fin-needed-p tp)
	(setf (tcp-fin-bit header) 1)))
    
    ;; Calculate and store the TCP checksum
    (store-tcp-checksum buffers (tcp-user-ip-header tp) (tcp-user-local-host-p tp))
    
    ;; Return the list of buffers we built
    (values buffers (max data-to-send 0))))

))

; From modified file DJ: L.NETWORK.KERNEL; NETSTAT.LISP#102 at 30-Nov-87 17:03:32
#10R NETWORK#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "NETWORK")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; KERNEL; NETSTAT  "


(defun tcp-socket-normal-fields (socket)
  (list
    (tv:scroll-parse-item
      `(:function ,#'(lambda (n) (or (tcp:ISS n) 0)) (,socket) NIL ("    ISS = ~16,8,'0R"))
      `(:function ,#'(lambda (n) (or (tcp:SND.WND n) 0)) (,socket) NIL (" SND.WND = ~5D"))
      `(:function ,#'(lambda (n) (or (tcp:SND.NXT n) 0)) (,socket) NIL (" SND.NXT = ~16,8,'0R"))
      `(:function ,#'(lambda (n) (or (tcp:SND.UP n) 0)) (,socket) NIL (" SND.UP = ~16,8,'0R"))
      `(:function ,#'(lambda (n) (or (tcp:SND.WL2 n) 0)) (,socket) NIL (" SND.WL2 = ~16,8,'0R"))
      `(:function ,#'(lambda (n) (or (tcp:SND.UNA n) 0)) (,socket) NIL (" SND.UNA = ~16,8,'0R")))
    (tv:scroll-parse-item
      `(:function ,#'(lambda (n) (or (tcp:IRS n) 0)) (,socket) NIL ("    IRS = ~16,8,'0R"))
      `(:function ,#'(lambda (n) (or (tcp:RCV.WND n) 0)) (,socket) NIL (" RCV.WND = ~5D"))
      `(:function ,#'(lambda (n) (or (tcp:RCV.NXT n) 0)) (,socket) NIL (" RCV.NXT = ~16,8,'0R"))
      `(:function ,#'(lambda (n) (or (tcp:RCV.UP n) 0)) (,socket) NIL (" RCV.UP = ~16,8,'0R"))
      `(:function ,#'(lambda (n) (or (tcp:SND.WL1 n) 0)) (,socket) NIL (" SND.WL1 = ~16,8,'0R"))
      `(:function ,#'(lambda (n) (or (tcp:tcp-user-remote-fin-sequence-number n) 0))
		  (,socket) NIL ("     FIN = ~16,8,'0R")))
    (tv:scroll-parse-item
      `(:function tcp:tcp-user-remote-mss (,socket) NIL ("    Remote MSS = ~D"))
      `(:function tcp:tcp-user-interface-mss (,socket) NIL (" Local MSS = ~D"))
      `(:function tcp:tcp-user-precedence (,socket) NIL (" Precedence = ~D"))
      `(:function tcp:tcp-user-security (,socket) NIL (" Security = ~D"))
      `(:function tcp:tcp-user-compartment (,socket) NIL (" Compartment = ~D"))
      `(:function tcp:tcp-user-handling (,socket) NIL (" Handling = ~D"))
      `(:function tcp:tcp-user-tcc (,socket) NIL (" TCC = ~D")))
    (tv:scroll-parse-item
      `(:function tcp:tcp-user-open-timeout (,socket) NIL ("    Timeouts: Open = ~D"))
      `(:function tcp:tcp-user-send-timeout (,socket) NIL (" Send = ~D"))
      `(:function tcp:tcp-user-cumulative-timeout (,socket) NIL (" Cumulative = ~D"))
      `(:function tcp:tcp-user-ack-delay (,socket) NIL (" ACK = ~D"))
      `(:function tcp:tcp-user-smoothed-round-trip-time (,socket) NIL (" SRTT = ~4F"))
      `(:function tcp:tcp-user-retransmission-timeout (,socket) NIL (" RTO = ~4F"))
      `(:function tcp:tcp-user-closed-p (,socket) NIL (" Closed = ~D")))
    (tv:scroll-parse-item
      `(:function tcp:tcp-user-send-data-length (,socket) NIL ("    Send Length = ~D"))
      `(:function tcp:tcp-user-send-data-offset (,socket) NIL (" Sent Unacknowledged = ~D"))
      `(:function ,#'(lambda (n) (- (tcp:tcp-user-send-data-length n)
				    (tcp:tcp-user-send-data-offset n)))
		  (,socket) NIL (" Unsent = ~D"))
      `(:function tcp:tcp-user-receive-data-length (,socket) NIL (" Receive Length = ~D"))
      `(:function ,#'(lambda (n) (- (tcp:tcp-user-receive-data-length n)
				    (tcp:tcp-user-receive-data-offset n)))
		  (,socket) NIL (" Receive Free = ~D")))
    (sent-statistics (tcp:tcp-user-statistics-block socket) "    ")
    (rcvd-statistics (tcp:tcp-user-statistics-block socket) "    ")
    ))

))


; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:04:55
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "


(defflavor tcp-stream-mixin
	 ((socket nil)				;The tcp-socket
	  (open nil)				;T if user has issued open
	  (closing nil)				;T if remote side has closed
	  (auto-push nil)			;T if open with auto-push
	  (bytes-read 0)			;total bytes read on this socket
	  (bytes-written 0)			;total bytes written on this socket
	  (timeout nil)				;T if send timed out
	  (urgent-output nil)			;T if in Urgent mode for output
	  (urgent-input nil)			;T if in Urgent mode for input
	  (urgent-offset nil)			;offset of urgent data
	  )
	 ()
  (:method-combination (:daemon-with-or :base-flavor-last :listen))
  (:gettable-instance-variables socket urgent-output urgent-input)
  (:settable-instance-variables urgent-output)
  (:inittable-instance-variables socket auto-push)
  )

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:04:57
#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))
	       (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.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:05:02
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "


(defmethod (tcp-buffered-stream :read-reply) (buffer offset)
  (push-fifo (cons buffer offset) input-buffer-fifo))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:05:05
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "


(defmethod (tcp-buffered-stream :next-input-buffer) (&optional no-hang-p)
  (declare (values buffer start end))
  (loop
    (cond ((send self :handle-all-replies))
	  ((not (fifo-empty-p input-buffer-fifo))
	   (let* ((elt (pop-fifo input-buffer-fifo))
		  (buffer (car elt))
		  (offset (cdr elt)))
	     ;;The following clears urgent-input mode if the urgent byte is in this buffer.
	     (setq urgent-input (not (null offset)))
	     (return (values buffer 0 (fill-pointer buffer)))))
	  ((not open)
	   (return nil))
	  (closing
	   (return nil))
	  (no-hang-p
	   (setq urgent-input (and urgent-offset (> urgent-offset bytes-read)))
	   (return nil))
	  (timeout
	   (send self :send-timeout))
	  (t
	   (send self :wait-for-reply
		      #'(lambda (b o c to)
			  (or (not (fifo-empty-p (cdr b)))
			      (not (cdr o))
			      (cdr c)
			      (cdr to)))
		      (locf input-buffer-fifo)
		      (locf open)
		      (locf closing)
		      (locf timeout))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:05:27
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "

(defmethod (tcp-buffered-stream :new-output-buffer) ()
  (declare (values buffer start end))
  (loop
    (cond ((send self :handle-all-replies))
	  (output-buffer-list
	   (return (values (pop output-buffer-list) 0 output-buffer-size)))
	  (timeout
	   (send self :send-timeout))
	  (t
	   (send self :wait-for-reply
		      #'(lambda (x y)
			  (or (cdr x) (cdr y)))
		      (locf output-buffer-list)
		      (locf timeout))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:05:46
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "

(defmethod (tcp-unbuffered-stream :read-reply) (buffer offset)
  ;;All this says is whether the urgent offset is within THIS buffer...
  (setq urgent-input (and offset (>= offset (length buffer))))
  (setq tyi-buffer buffer))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:05:51
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "

(defmethod (tcp-unbuffered-stream :tyi) (&optional eof)
  (loop
    (cond ((send self :handle-all-replies))
	  (untyi-char
	   (return (prog1 untyi-char (setq untyi-char nil))))
	  (tyi-buffer
	   (let* ((buffer tyi-buffer)
		  (byte (aref buffer 0)))
	     (setq tyi-buffer nil)
	     (send socket :receive buffer)
	     (setq urgent-input (and urgent-offset (>= urgent-offset bytes-read)))
	     (return byte)))
	  ((or closing (not open))
	   (if eof
	       (global:signal 'sys:end-of-file :format-string "End of File on TCP stream")
	     (return nil)))
	  (timeout
	   (send self :send-timeout))
	  (t
	   (send self :wait-for-reply
		      #'(lambda (u b o c to)
			  (or (cdr u) (cdr b) (not (cdr o)) (cdr c) (cdr to)))
		      (locf untyi-char)
		      (locf tyi-buffer)
		      (locf open)
		      (locf closing)
		      (locf timeout))))))


))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:05:58
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "

(defmethod (tcp-unbuffered-stream :listen) ()
  (loop
    (unwind-protect
	(cond ((send self :handle-all-replies))
	      (untyi-char
	       (return t))
	      (tyi-buffer
	       (return t))
	      ((or closing (not open))
	       (return t))
	      (timeout
	       (return t))
	      (t
	       (return nil)))
      (setq urgent-input (and urgent-offset (>= urgent-offset bytes-read))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:06:01
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "

(defmethod (tcp-unbuffered-stream :tyi-no-hang) (&optional eof)
  (loop
    (cond ((send self :handle-all-replies))
	  (untyi-char
	   (return (prog1 untyi-char (setq untyi-char nil))))
	  (tyi-buffer
	   (let* ((buffer tyi-buffer)
		  (byte (aref buffer 0)))
	     (setq tyi-buffer nil)
	     (send socket :receive buffer)
	     (setq urgent-input (and urgent-offset (>= urgent-offset bytes-read)))
	     (return byte)))
	  ((or closing (not open))
	   (if eof
	       (global:signal 'sys:end-of-file :format-string "End of File on TCP stream")
	     (return nil)))
	  (timeout
	   (send self :send-timeout))
	  (t
	   (return nil)))))


))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#49 at 1-Dec-87 12:06:06
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  "

(defmethod (tcp-unbuffered-stream :tyo) (byte)
  (loop
    (cond ((send self :handle-all-replies))
	  ((not open)
	   (return nil))
	  (tyo-buffer
	   (let ((buffer tyo-buffer))
	     (setq tyo-buffer nil)
	     (setf (aref buffer 0) byte)
	     (setf (fill-pointer buffer) 1)
	     (send socket :write-data buffer :urgent urgent-output)
	     (return t)))
	  (timeout
	   (send self :send-timeout))
	  (t
	   (send self :wait-for-reply
		      #'(lambda (b o to)
			  (or (cdr b) (not (cdr o)) (cdr to)))
		      (locf tyo-buffer)
		      (locf open)
		      (locf timeout))))))

))