;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 (&optional (save-current nil))
  (if *laser2-stream*
      (progn
	(if (not (equal (send (send *laser2-stream* :server-process) :name)
			"Laser2 Server Process"))
	    (start-laser2-server))
	(reset-laser2 save-current))
    (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*
  (let ((user-id "LASER2") stream conn)
    (do-forever
      ;1; Wait for job.*
      (process-wait "No Jobs" #'(lambda (x) (send x ':printer-queue)) self)
      (setq current-job (pop printer-queue))
      (process-lock (locf laser2-owner-lock))
      (cond
	((equal (car current-job) ':FILE)
	 (with-open-file (stream (cadr si:*default-printer*))
	   (send stream :set-force-output-p nil)
	   (apply self :print-file (append (cdr current-job) (list stream)))))
	((equal (car current-job) ':STREAM)
	 (with-open-file (stream (cadr si:*default-printer*))
	   (send stream :set-force-output-p nil)
	   (apply self :print-stream (append (cdr current-job) (list stream)))))
	((equal (car current-job) ':ARRAY)
	 (with-open-file (stream (cadr si:*default-printer*))
	   (apply self :print-bit-array (append (cdr current-job) (list stream))))
	 (deallocate-resource 'tv:hardcopy-bit-array-resource (cadr current-job)))
	((equal (car current-job) :REMOTE-STREAM)
	 (do-forever
	   (setq conn (catch-error (chaos:connect (cadr si:*default-printer*)
						  "LASER2-PIFILE") nil))
	   (if (not conn) (process-sleep 600. "Waiting for Server")
	     (setq stream (chaos:make-stream conn))
	     (laser2-print-stream1 (cadr current-job) *default-orientation* stream)
	     (return))))
	((equal (car current-job) :REMOTE-FILE)
      	 (do-forever
	   (setq conn (catch-error (chaos:connect (cadr si:*default-printer*)
						  "LASER2-PIFILE") nil))
	   (if (not conn) (process-sleep 600. "Waiting for Server")
	     (setq stream (chaos:make-stream conn))
	     (send self :print-file (cadr current-job) *default-orientation* stream)
	     (return))))
	((equal (car current-job) :REMOTE-ARRAY)
	 (do-forever
	   (setq conn (catch-error (chaos:connect (cadr si:*default-printer*)
						  "LASER2-PIFILE") nil))
	   (if (not conn) (process-sleep 600. "Waiting for Server")
	     (setq stream (chaos:make-stream conn))
	     (apply self :print-bit-array (append (cdr current-job) (list stream)))
	     (return)))))
      (process-unlock (locf laser2-owner-lock))
      (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-server))


;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)

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

(defun laser2-remote-server (&aux conn stream status)
    (setq conn (chaos:listen "LASER2-PIFILE"))
    (if laser2-owner-lock
	(chaos:reject conn "Printer Busy")
      (process-lock (locf laser2-owner-lock))
      (unwind-protect
	  (catch-error
	    (if (progn
		  (setq status (get-imagen-status (substring (cadr si:*default-printer*) 9.)))
		  (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 (cadr si:*default-printer*))
		(stream-copy-until-eof stream tcp-stream)))))
      (process-unlock (locf laser2-owner-lock))))

(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)))))