;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.10
;;; Reason:
;;;  When TCP Disk Server was asked to WRITE a partition, it didn't increment
;;;  the disk address between disk-writes.
;;; Written 27-May-88 13:55:06 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Cthulhu from band 2
;;; with Experimental System 124.3, Experimental Local-File 74.0, Experimental File-Server 23.0, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.0, Experimental Lambda-Diag 16.0, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8.


; From modified file DJ: L.NETWORK.IP-TCP.SERVER; DISK.LISP#23 at 27-May-88 13:55:33
#10R TCP-APPLICATION#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; DISK  "

(defun serial-stream-disk-server (stream)
  ;; This allows someone to set up the password database to allow disk transfers
  ;; only from certain hosts.  Add an initial password negotiation in future.
  (or (validate-network-server-password "FOO" "BAR" si:local-host) 
      (return-from serial-stream-disk-server nil))
  (serial-stream-disk-server-internal stream))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; DISK.LISP#23 at 27-May-88 13:59:47
#10R TCP-APPLICATION#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; DISK  "

(defun serial-stream-disk-server-internal (stream &aux rqb)
  (unwind-protect
      (do ((opcode))
	  ((null (setq opcode (int-char-if-any (send stream :tyi)))))
	(ecase opcode
	  ((#\R #\W)
	   (let ((unit (receive-32b stream))
		 (n-pages (receive-32b stream))
		 (address (receive-32b stream)))
	     (cond ((not rqb)
		    (setq rqb (si:get-disk-rqb n-pages)))
		   ((not (= n-pages (si:rqb-npages rqb)))
		    (si:return-disk-rqb (prog1 rqb (setq rqb nil)))
		    (setq rqb (si:get-disk-rqb n-pages))))
	     (ecase opcode
	       (#\R
		(si:disk-read rqb unit address)
		(send stream :tyo #\R)
		(transmit-string (si:rqb-8-bit-buffer rqb)
				 stream))
	       (#\W
		(receive-string stream (si:rqb-8-bit-buffer rqb))
		(si:disk-write rqb unit address)
		(send stream :tyo #\R)))))
	  (#\A
	   (let ((op (int-char-if-any (send stream :tyi)))
		 (unit (receive-32b stream))
		 (n-pages (receive-32b stream))
		 (address (receive-32b stream))
		 (n-operations (receive-32b stream)))
	     (cond ((not rqb)
		    (setq rqb (si:get-disk-rqb n-pages)))
		   ((not (= n-pages (si:rqb-npages rqb)))
		    (si:return-disk-rqb (prog1 rqb (setq rqb nil)))
		    (setq rqb (si:get-disk-rqb n-pages))))
	     (send stream :build-more-buffers
			  (if (eq op #\W) 16. 0)	;Network input buffers
			  (if (eq op #\R) 16. 0))	;Network output buffers
	     (dotimes (j n-operations)
	       (ecase op
		 (#\R
		  (si:disk-read rqb unit address)
		  (incf address n-pages)
		  (transmit-string (si:rqb-8-bit-buffer rqb) stream))
		 (#\W
		  (receive-string stream (si:rqb-8-bit-buffer rqb))
		  (si:disk-write rqb unit address)
		  (incf address n-pages))))))
	  (#\N
	   (tv:notify nil "~A" (receive-string stream))
	   (send stream :tyo #\R)))
	(send stream :force-output))
    (and rqb (si:return-disk-rqb (prog1 rqb (setq rqb nil))))))

))