#|| -*- Mode:LISP; Package:(NEWSRV GLOBAL); Fonts:(CPTFONTB); Base:10 -*-

  Copyright LISP Machine, Inc. 1985
   See filename "Copyright.Text" for
  licensing and release information.

Some new chaosnet servers: 
 (OPEN-REMOTE-SERIAL-STREAM "<hostname>" &optional (baud 9600))
 (REMOTE-SERIAL-STREAM-STATUS "<hostname>")

If the remote stream is stuck in serial finish then that is probably
because the data-set-ready line is not enabled or jumpered and there
is pending output, xmit buffer not empty.

 (REMOTE-MAGTAPE "<hostname>")
 (FREE-MAGTAPE-FOR-REMOTE) ; use on host if needed.

||#


;; GENERIC CHAOSNET FUNCTIONS.

(DEFUN VANILLA-CHAOS-SERVER-FUNCTION (CONTACT FUNCTION REJECTP)
  (WITH-OPEN-STREAM (STREAM (CHAOS:OPEN-STREAM NIL CONTACT))
    (LET ((CONN (SEND STREAM :CONNECTION)))
      (LET ((ST (SUBSTRING (CHAOS:PKT-STRING (CHAOS:CONN-READ-PKTS CONN))
			   (STRING-LENGTH CONTACT))))
	(LET ((REJECT? (AND REJECTP (FUNCALL REJECTP ST))))
	  (IF REJECT?
	      (RETURN-FROM VANILLA-CHAOS-SERVER-FUNCTION
		(CHAOS:REJECT CONN REJECT?))))
	(CHAOS:ACCEPT CONN)
	(SEND TV:WHO-LINE-FILE-STATE-SHEET :ADD-SERVER CONN CONTACT)
	(CONDITION-CASE ()
	    (FUNCALL FUNCTION STREAM ST)
	  (SYS:REMOTE-NETWORK-ERROR NIL))))))


(DEFUN ADD-VANILLA-CHAOS-SERVER (CONTACT FUNCTION &KEY REJECTP)
  (check-arg-type contact string)
  (ADD-INITIALIZATION CONTACT
		      `(PROCESS-RUN-FUNCTION ,(FORMAT NIL
						      "~A server"
						      contact)
					     'vanilla-chaos-server-function
					     ,contact
					     ',function
					     ',REJECTP)
		      nil
		      'CHAOS:SERVER-ALIST))


;; REMOTE SERIAL STREAM SUPPORT

(defun open-remote-serial-stream (host &optional (baud 9600))
  (make-auto-force-output-stream
    (chaos:open-stream host
		       (format nil "SDU-SERIAL-B ~D"
			       baud))))

(add-vanilla-chaos-server "SDU-SERIAL-B"
			  'sdu-serial-b-server
			  :REJECTP 'SDU-SERIAL-B-IN-USE)

(DEFUN SDU-SERIAL-B-IN-USE (IGNORE)
  (LET ((DEVICE (SEND (FS:PARSE-PATHNAME "SDU-SERIAL-B:") :HOST)))
    (COND ((NOT (SEND DEVICE :ALLOCATE-IF-EASY))
	   "device not available")
	  ((SEND device :GET-LOCK NIL)
	   NIL)
	  ('else
	   "Serial port B in use by on host"))))


(defvar *serial-b-buffer* (make-string 1000))

(defun sdu-serial-b-server (remote extra)
  (with-open-file (local "SDU-SERIAL-B:")
    (let ((baud (parse-integer extra :junk-allowed t)))
      (if baud
	  (send local :set-baud-rate baud)))
    (let ((proc)
	  (name "serial b remote -> local"))
      (unwind-protect
	  (*catch 'remote-closed
	    (setq proc (process-run-function name
					     #'serial-b-remote->local
					     remote local
					     current-process))
	    (do-forever
	      (send remote :tyo (send local :tyi))
	      (do ((n (send local :INPUT-CHARACTERS-AVAILABLE))
		   (j 0 (1+ j)))
		  ((= j n)
		   (OR (ZEROP J)
		       (send remote :string-out *serial-b-buffer* 0 J)))
		(setf (aref *serial-b-buffer* j) (send local :tyi)))
	      (send remote :force-output)))
	(and proc (eq (si:process-name proc) name)
	     (send proc :kill))))))

(defun serial-b-remote->local (remote local superior)
  (CONDITION-CASE ()
      (DO ((C))
	  ((null (setq c (send remote :tyi))))
	(send local :tyo c))
    (SYS:REMOTE-NETWORK-ERROR NIL))
  (send superior :interrupt #'(lambda ()
				(*throw 'remote-closed nil)))
  (si:process-wait-forever))


(add-vanilla-chaos-server "SDU-SERIAL-B-STATUS"
			  'sdu-serial-b-status-server)


(DEFUN REMOTE-SERIAL-STREAM-STATUS (host)
  (format t "~&Getting status of SDU-SERIAL-B on ~S~%" host)
  (with-open-stream (s (chaos:open-stream host "SDU-SERIAL-B-STATUS"))
    (stream-copy-until-eof s standard-output)))


(defun sdu-serial-b-status-server (standard-output ignore)
  (let ((dev (send (fs:parse-pathname "sdu-serial-b:") :host))
	(p))
    (format t "Device: ~S,~%" dev)
    (cond ((setq p (car (send dev :lock)))
	   (format t "Locked by ~S state: ~A~%"
		   p (send p :whostate))))
    (si:sdu-serial-status)))

(defun make-auto-force-output-stream (substream)
  #'(lambda (op &optional arg1 &rest args)
      (multiple-value-prog1 (apply substream op arg1 args)
			    (if (memq op '(:tyo :string-out))
				(send substream :force-output)))))

;; magnetic tape

(add-vanilla-chaos-server "MAGTAPE-FUNCTIONS"
			  'MAGTAPE-FUNCTIONS-SERVER
			  :REJECTP 'MAGTAPE-FUNCTIONS-IN-USE)

(DEFUN MAGTAPE-FUNCTIONS-IN-USE (IGNORE)
  (LET ((DEVICE (SEND (FS:PARSE-PATHNAME "HALF-INCH-TAPE:") :HOST)))
    (COND ((NOT (SEND DEVICE :ALLOCATE-IF-EASY))
	   "device not available")
	  ((SEND device :GET-LOCK NIL)
	   (FS:TM-INIT)
	   NIL)
	  ('else
	   "magtape in use on host"))))


(defun FREE-MAGTAPE-FOR-REMOTE ()
  (with-open-file (s "HALF-INCH-TAPE:")
    s
    "half inch tape now free"))


(DEFUN REMOTE-MAGTAPE (HOST)
  (WITH-OPEN-STREAM (S (CHAOS:OPEN-STREAM HOST "MAGTAPE-FUNCTIONS"))
    (DO ((COMMAND))
	((NULL (EXECUTE-REMOTE-MAGTAPE-COMMAND
		 S	
		 (PROMPT-AND-READ :READ "~&Magtape Function on ~A:"
				  (send (send (send s :connection) :foreign-host)
					:name))))))))


(DEFUN EXECUTE-REMOTE-MAGTAPE-COMMAND (S C)
  (COND ((SYMBOLP C)
	 (COND ((STRING-EQUAL "HELP" C)
		(FORMAT T "~&Magtape functions allowed:~
                           ~%(FS:MT-REWIND) (FS:MT-WRITE-EOF) (FS:RESTORE-MAGTAPE)~
                           ~%(FS:COPY-DIRECTORY), and the atoms HELP and EXIT~%"))
	       ((STRING-EQUAL "EXIT" C)
		(RETURN-FROM EXECUTE-REMOTE-MAGTAPE-COMMAND NIL))
	       ('ELSE
		(FORMAT T "~&Unknown magtape command, try HELP: ~S~%" C))))
	((OR (ATOM C) (NOT (SYMBOLP (CAR C))))
	 (FORMAT T "~&Illegal magtape command, try HELP: ~S~%" C))
	((NOT (MEMQ (CAR C) '(FS:MT-REWIND FS:MT-WRITE-EOF FS:RESTORE-MAGTAPE
					   FS:COPY-DIRECTORY)))
	 (FORMAT T "~&Unknown magtape command, try HELP: ~S~%" C))
	('ELSE
	 (LET ((*PACKAGE* (FIND-PACKAGE "NEWSRV"))
	       (*READTABLE* SI:INITIAL-READTABLE)
	       (BASE 10)
	       (IBASE 10))
	   (PRINT C S))
	 (DISPLAY-REMOTE-RESULT S)))
  T)

(DEFUN DISPLAY-REMOTE-RESULT (S)
  (DO ((C))
      ((NULL (SETQ C (SEND S :TYI))))
    (COND ((AND (= C #\NETWORK) (NOT (= (SETQ C (SEND S :TYI))
					#\NETWORK)))
	   (COND ((= C #\BREAK)
		  (RETURN))
		 ('ELSE
		  (FUNCALL
		    (LET ((READTABLE SI:INITIAL-READTABLE)
			  (PACKAGE (FIND-PACKAGE "NEWSRV")))
		      (READ S))
		    S))))
	  ('ELSE
	   (SEND STANDARD-OUTPUT :TYO C)))))


(DEFUN MAGTAPE-FUNCTIONS-SERVER (STREAM IGNORE)
  (LET ((REMOTE-HACKING-STREAM (MAKE-REMOTE-HACKING-STREAM STREAM)))
    (LET ((*PACKAGE* (PKG-FIND-PACKAGE "NEWSRV"))
	  (*STANDARD-INPUT* REMOTE-HACKING-STREAM)
	  (*STANDARD-OUTPUT* REMOTE-HACKING-STREAM)
	  (*ERROR-OUTPUT* REMOTE-HACKING-STREAM)
	  (*QUERY-IO* REMOTE-HACKING-STREAM)
	  (BASE 10)
	  (IBASE 10))
      (DO-FOREVER
	(CONDITION-CASE (ERR)
	    (EVAL (READ STREAM))
	  (SYS:REMOTE-NETWORK-ERROR
	   (RETURN))
	  (ERROR
	   (SEND ERR :REPORT *ERROR-OUTPUT*)))
	(SEND STREAM :TYO #\NETWORK)
	(SEND STREAM :TYO #\BREAK)
	(SEND STREAM :FORCE-OUTPUT)))))



(defvar *serial-b-buffer* (make-string 1000))

(defun sdu-serial-b-server (remote ignore)
  (with-open-file (local "SDU-SERIAL-B:")
    (let ((proc)
	  (name "serial b remote -> local"))
      (unwind-protect
	  (*catch 'remote-closed
	    (setq proc (process-run-function name
					     #'serial-b-remote->local
					     remote local
					     current-process))
	    (do-forever
	      (send remote :tyo (send local :tyi))
	      (do ((n (send local :INPUT-CHARACTERS-AVAILABLE))
		   (j 0 (1+ j)))
		  ((= j n)
		   (send remote :string-out *serial-b-buffer* 0 n))
		(setf (aref *serial-b-buffer* j) (send local :tyi)))
	      (send remote :force-output)))
	(and proc (eq (si:process-name proc) name)
	     (send proc :kill))))))