;1;; -*- Mode:LISP; Package:LASER2; Base:8; Fonts:(CPTFONT HL12B) -*-*
;1;; Copyright (c) 1985, LISP Machine, Inc.*

;1;; Description: Laser2 server*
;1;; Programmer: James M. Turner*
;1;; Last Modification: 11-Jan-1985*
;1;;*
;1;; Change History:*
;1;;*

;1;; Abandon ship!*

(defmethod (laser2-stream :reset-laser2) ()
  (send server-process ':reset))

(defun reset-laser2 (&optional (save-current nil))
  (send *laser2-stream* :reset-laser2)
  (if save-current
      (push (send *laser2-stream* :current-job) (send *laser2-stream* :printer-queue))))

(defun start-laser2-processes-if-needed ()
  (if *laser2-stream*
      (progn
	(if (not (equal (send (send *laser2-stream* :server-process) :name)
			"Laser2 Server Process"))
	    (start-laser2-server)))
    (setq *laser2-stream* (make-instance 'laser2-stream))
    (start-laser2-server)))

(defun start-laser2-server ()
  (send *laser2-stream*
	':set-server-process
	(process-run-restartable-function "Laser2 Server Process"
					  #'laser2-server)))
(defun laser2-server ()
  (send *laser2-stream* ':run-server))


;1;; Checks queue for jobs waiting, then prints them.*

(defmethod (laser2-stream :run-server) ()
  ;1; So we can open files*
  (setq tcp-stream nil)
  (let ((user-id "LASER2") rmname fndname)
    (do-forever
      ;1; Wait for job.*
      (process-wait "No Jobs" #'(lambda (x) (send x ':printer-queue)) self)
      (setq current-job (pop printer-queue))
      (unwind-protect
	  (*catch 'no-printer
	    (setq fndname nil)
	    (cond ((equal laser2-remote :NONE)
		   (tv:background-notify "No TCP Bridge Available, Sorry")
		   (*throw 'no-printer t)))
	    (setq fndname (second (second current-job)))
	    (cond 
	      ((listp laser2-remote)
	       (*catch 'open
		 (do-forever
		   (dolist (hst laser2-remote)
		     (setq rmname hst)
		     (setq tcp-stream (catch-error
					    (chaos:connect
					      hst
					      (string-append "LASER2-PIFILE "
							     fndname)) nil))
			 (if tcp-stream (*throw 'open nil)))
		       (process-sleep 600. "No Printers Available")))
		   (setq tcp-stream (chaos:make-stream tcp-stream)))
		  (t
		   (setq tcp-stream (open (setq rmname
						(string-append "TCP-HOST:" fndname))
					  :direction :output))
		   (send tcp-stream :set-force-output-p nil)))
	    (tv:background-notify "Now Printing ~A on ~A" (car current-job)
				  (second (second current-job)))
	    (cond
	      ((equal (car current-job) ':FILE)
	       (apply self :print-file (cddr current-job)))
	      ((equal (car current-job) ':STREAM)
	       (apply self :print-stream (cddr current-job)))
	      ((equal (car current-job) ':ARRAY)
	       (apply self :print-bit-array (cddr (butlast current-job)))
	       (if (not (last current-job))
		   (deallocate-resource 'tv:hardcopy-bit-array-resource (caddr current-job))))))
	(if tcp-stream
	    (close tcp-stream))
	(setq tcp-stream nil))
      (setq current-job nil))))

(defun print-laser2-queue (&optional (stream terminal-io) (count 1))
  (dolist (item (reverse (send *laser2-stream* :printer-queue)))
    (selectq (car item)
      (:FILE
       (format stream "~%Item ~D: File ~A" count (cadr item)))
      (:STREAM
       (format stream "~%Item ~D: Stream ~A" count (cadr item)))
      (:DPRINT
       (format stream "~%Item ~D: Raw Laser2 File ~A" count (cadr item)))
      (:ARRAY
       (format stream "~%Item ~D: A bit array" count)))
    (incf count)))

(defun remove-queue-item (n &aux queue)
  (setq queue (send *laser2-stream* :printer-queue))
  (setq n (- (length queue) n))
  (if (or (minusp n) ( n (length queue))) ()
    (if (= n 0)
	(send *laser2-stream* :set-printer-queue (cdr queue))
      (rplacd (nthcdr (1- n) queue)
	      (nthcdr (1+ n) queue))))
  (print-laser2-queue))

;1;; Get things running.*

(defun laser2-start-processes ()
  (start-laser2-processes-if-needed))


;1;; The various things that can be done remotely.*

(add-initialization "LASER2-PIFILE" '(process-run-function "Remote Imagen Server"
							  'laser2-remote-server)
		    nil 'chaos:server-alist)

(add-initialization "LASER2-SEARCH" '(process-run-function "Reply to Broadcast"
							   'laser2-find-answer)
		    nil 'chaos:server-alist)

;1;; And the functions that go with them.*

(defun laser2-find-server ()
  (let ((responded nil))
    (chaos:poll-hosts (chaos:list-all-net-machines :lispm) ; don't bother everybody
		      "LASER2-SEARCH" nil #'ignore
		      #'(lambda (ignore n y)
			  (if (string-equal (chaos:pkt-string y) "HAVE-TCP")
			      (push (multiple-value-bind (ignore b)
					(chaos:address-parse n) b)
				    responded)))
		      :ignore-states '(chaos:rfc-sent-state))
    responded))

(defun laser2-find-answer ()
  (start-laser2-processes-if-needed)
  (if (send *laser2-stream* :laser2-remote)
      (chaos:fast-answer-string "LASER2-SEARCH" "NO-TCP")
    (chaos:fast-answer-string "LASER2-SEARCH" "HAVE-TCP")))

(defun laser2-remote-server (&aux address conn stream status add)
  (let ((user-id "LASER2"))
    (setq conn (chaos:listen "LASER2-PIFILE"))
    (setq add (chaos:pkt-string (chaos:read-pkts-last conn)))
    (if ( (string-length add) 15.)
	(setq address (substring (chaos:pkt-string (chaos:read-pkts-last conn)) 14.)))
    (unwind-protect
	(catch-error
	  (if (progn
		(setq status (get-imagen-status address))
		(not (and status (plusp (getf status :protocols-accepted)))))
	      (chaos:reject conn "Printer Busy")
	    (chaos:accept conn)
	    (setq stream (chaos:make-stream conn))
	    (with-open-file (tcp-stream (string-append "TCP-HOST:" address))
	      (stream-copy-until-eof stream tcp-stream))) nil))))

(defun get-imagen-status (address &key &optional
			  (tries 10)
			  (try-pause 0.01)
			  (wait-pause 0.01))
  "Returns a plist describing the status of the imagen at the internet ADDRESS"
  (check-type address string)
  (check-type tries (fixnum 1))
  (check-type try-pause number)
  (check-type wait-pause number)
  (let (result)
    (dotimes (j tries)
      (if (setq result (get-imagen-status-1 address (ROUND (* wait-pause 60))))
	  (return-from get-imagen-status result))
      (process-sleep (ROUND (* try-pause 60)) "imagen status sleep"))))

(defconst imagen-udp-status-pkt-size 256)

(defun get-imagen-status-1 (address pause)
  (with-open-file (stream (string-append "TCP-HOST:" address "#IMAGEN")
			  :for-udp t)
    (using-resource (array fs:simple-string-buffer imagen-udp-status-pkt-size)
      (fill array 0)
      (send stream :write-packet array 0 imagen-udp-status-pkt-size)
      (dotimes (j pause)
	;; :listen cant be use inside a process-wait function because
	;; it sends a message to the device driver which needs a process
	;; to run in order to get the reply.
	(if (send stream :listen) (return))
	(process-sleep 1 "imagen status reply"))
      (WHEN (SEND STREAM :LISTEN)
	(SEND STREAM :READ-PACKET ARRAY)
	(let ((plist (PARSE-IMAGEN-STATUS-PACKET ARRAY)))
	  (setf (getf plist :address) address)
	  plist)))))

(DEFUN BIG-ENDIAN-BYTES (ARRAY &REST BYTES)
  "Combine bytes into an integer, most significant come first"
  (DO ((NUMBER 0 (+ (* NUMBER 256) (AREF ARRAY (CAR L))))
       (L BYTES (CDR L)))
      ((NULL L) NUMBER)))

(DEFUN PARSE-IMAGEN-STATUS-PACKET (ARRAY)
  (DO ((PLIST (LIST :STATUS-BYTE (BIG-ENDIAN-BYTES ARRAY 2)
		    :AGE (BIG-ENDIAN-BYTES ARRAY 4 5 6 7)
		    :PROTOCOLS-SUPPORTED (BIG-ENDIAN-BYTES ARRAY 8 9 10 11)
		    :PROTOCOLS-ACCEPTED  (BIG-ENDIAN-BYTES ARRAY 12 13 14 15)
		    :ENGINE-STATUS (SUBSTRING ARRAY
					      (BIG-ENDIAN-BYTES ARRAY 16 1)
					      (+ (BIG-ENDIAN-BYTES ARRAY 16 1)
						 (BIG-ENDIAN-BYTES ARRAY 18 19)))))
       (PROBLEMS '((#x01 :OTHER)
		   (#x02 :NO-PAPER)
		   (#x04 :PAPER-JAM)
		   (#x08 :LACKING-CONSUMABLES)
		   (#xF0 :JOB-IN-PROGRESS))
		 (CDR PROBLEMS)))
      ((NULL PROBLEMS) PLIST)
    (IF (BIT-TEST (CAAR PROBLEMS) (GETF PLIST :STATUS-BYTE))
	(PUSH (CADAR PROBLEMS) (GETF PLIST :PROBLEMS)))))