;;;
;;; server.lisp
;;;
;;; Dummied up server
;;;
;;; Copyright (C) 2005, Alastair Bridgewater
;;;

(in-package :clxs)

;; These are constants defined by the protocol.
(defconstant +protocol-major-version+ 11)
(defconstant +protocol-minor-version+ 0)

;; This is the list of error type symbols, in order, with a
;; blank spot at the beginning so that we can use POSITION
;; to find the right code given the symbol.
(defparameter +error-code-list+
  '(nil :request :value :window :pixmap :atom :cursor :font
    :match :drawable :access :alloc :colormap :gcontext
    :idchoice :name :length :implementation))

;; These are set at the discretion of the vendor.
(defparameter +server-vendor+ "CLXS")
(defparameter +server-release+ 0)

;; These are dummy values, and dependant on the input subsystem.
(defparameter +motion-buffer-size+ 0)
(defparameter +min-keycode+ 8)
(defparameter +max-keycode+ 8)

;; These are dummy values, and depend on the display engine.
(defparameter *image-byte-order* :lsb-first)
(defparameter *bitmap-format-bit-order* :least-significant)
(defparameter *bitmap-format-scanline-unit* 32)
(defparameter *bitmap-format-scanline-pad* 32)

;; Pixmap formats
(defparameter *pixmap-formats* '((1 1 32))
  "A list of lists representing pixmap formats.
Each pixmap format is a list (depth bits-per-pixel scanline-pad).")

;; Screens
(defparameter *screens* nil
  "A list of screens, format undecided.")

(defparameter +max-request-length+ (ash +request-buffer-size+ -2))

(defvar *server* nil)
(defvar *show-packet-contents* nil)

(defun protocol-error (error &optional (datum 0))
  (throw 'protocol-error (values error datum)))

(defun send-error-response (network-client client packet error datum)
  (let ((response (make-array 32 :element-type '(unsigned-byte 8)
			      :initial-element 0)))
    (format t "Error response ~A opcode ~A request ~A.~%" error
	    (aref packet 0) (client-state-request-number client))
    ;; FIXME: The error structure has a spot for minor opcode. Where's that?
    (setf (aref response 1) (position error +error-code-list+))
    (setf (aref response 10) (aref packet 0))
    (if (eq (client-state-byte-order client) :lsb-first)
	(progn
	  (setf (request-integer response 2 2 :little-endian t)
		(client-state-request-number client))
	  (setf (request-integer response 4 4 :little-endian t) datum))
	(progn
	  (setf (request-integer response 2 2)
		(client-state-request-number client))
	  (setf (request-integer response 4 4) datum)))
    (send-packet network-client response)))

(defun clxs-request-dispatch (network-client client packet)
  (let ((length (if (eq (client-state-byte-order client) :lsb-first)
		    (request-integer packet 2 2 :little-endian t)
		    (request-integer packet 2 2))))
    ;; A length of 0 is an error, and I don't know the semantics.
    ;; A length beyond max-length is a Length error, and we should
    ;; ignore the rest of the request.
    ;; We don't handle either condition yet.
    (if (< (network-client-packet-size network-client) (ash length 2))
	(progn
	  (setf (network-client-packet-size network-client) (ash length 2)))
	(progn
	  (incf (client-state-request-number client))
	  (multiple-value-bind (error datum)
	      (catch 'protocol-error
		(let ((request-handler (request-handler (aref packet 0))))
		  (unless request-handler (protocol-error :implementation))
		  (funcall request-handler client packet)
		  nil))
	    (when error (send-error-response network-client client
					     packet error datum)))
	  (when *show-packet-contents* (format t "~A~%" packet))
	  (network-client-packet-complete network-client)
	  (setf (network-client-packet-size network-client) 4)))))

(defun initialize-request-dispatch (client)
  (setf (network-client-packet-received-callback
	 (client-state-network-client client))
	(lambda (network-client packet)
	  (clxs-request-dispatch network-client client packet))))

(defun send-authfail-message (client message little-endian)
  (let ((reply (make-array (+ 8 (logand -4 (+ 3 (length message))))
			   :element-type '(unsigned-byte 8)
			   :initial-element 0)))
    (setf (aref reply 0) 0)
    (setf (aref reply 1) (length message))
    (if little-endian
	(progn
	  (setf (request-integer reply 2 2 :little-endian t) +protocol-major-version+)
	  (setf (request-integer reply 4 2 :little-endian t) +protocol-minor-version+)
	  (setf (request-integer reply 6 2 :little-endian t) (ash (+ 3 (length message)) -2)))
	(progn
	  (setf (request-integer reply 2 2) +protocol-major-version+)
	  (setf (request-integer reply 4 2) +protocol-minor-version+)
	  (setf (request-integer reply 6 2) (ash (+ 3 (length message)) -2))))
    (dotimes (i (length message))
      (setf (aref reply (+ 8 i)) (char-code (aref message i))))
    #+(or) (format t "~A~%" reply)
    (send-packet client reply)
    #+nil    (sb-unix:unix-write
     (sb-bsd-sockets:socket-file-descriptor
      (slot-value client 'socket))
     (sb-sys:vector-sap reply)
     0 (length reply))))

(defun screen-data-length ()
  "Compute the total amount of data required to represent all of the screens, in words."
  ;; FIXME: Implement.
  ;; 10 words per screen plus 2 words per depth plus 6 words per visual.
  ;; visuals are per depth, depths are per screen.
  10)

(defun clxs-initialize-client-connection (network-client packet)
  (let ((client (make-instance 'client-state)))
    (setf (slot-value client 'network-client) network-client)
    (setf (slot-value client 'byte-order) (if (eq #x6c (aref packet 0))
					      :lsb-first :msb-first))
    (setf (client-state-request-number client) 0)
    ;; FIXME: Error checking would be nice here.
    (assign-resource-range client)

    (initialize-request-dispatch client)

    ;; Okay, now that we have the client state setup we need
    ;; to send the server response packet back.
    (let* ((pixmap-data-start (+ 8 32 (logand -4 (+ 3 (length +server-vendor+)))))
	   (screen-data-start (+ pixmap-data-start (* 8 (length *pixmap-formats*))))
	   (response-length (+ 8 (* 2 (length *pixmap-formats*))
			       (ash (+ 3 (length +server-vendor+)) -2)
			       (screen-data-length)))
	   (response (make-array (+ 8 (ash response-length 2))
				 :element-type '(unsigned-byte 8)
				 :initial-element 0)))
      (declare (ignorable screen-data-start))
      (setf (aref response 0) 1) ; success
      #+nil (setf (aref response 1) 0) ; unused
      (if (eq (client-state-byte-order client) :lsb-first)
	  (progn
	    (setf (request-integer response 2 2 :little-endian t) +protocol-major-version+)
	    (setf (request-integer response 4 2 :little-endian t) +protocol-minor-version+)
	    (setf (request-integer response 6 2 :little-endian t) response-length)
	    (setf (request-integer response 8 4 :little-endian t) +server-release+)
	    (setf (request-integer response 12 4 :little-endian t)
		  (client-state-resource-id-base client))
	    (setf (request-integer response 16 4 :little-endian t)
		  (client-state-resource-id-mask client))
	    (setf (request-integer response 20 4 :little-endian t) +motion-buffer-size+)
	    (setf (request-integer response 24 2 :little-endian t) (length +server-vendor+))
	    (setf (request-integer response 26 2 :little-endian t) +max-request-length+)
	    ;; FIXME: HACK below for number of screens.
	    (setf (aref response 28) 1 #+nil(length *screens*))
	    (setf (aref response 29) (length *pixmap-formats*))
	    (setf (aref response 30)
		  (position *image-byte-order*
			    '(:lsb-first :msb-first)))
	    (setf (aref response 31)
		  (position *bitmap-format-bit-order*
			    '(:least-significant :most-significant)))
	    (setf (aref response 32) *bitmap-format-scanline-unit*)
	    (setf (aref response 33) *bitmap-format-scanline-pad*)
	    (setf (aref response 34) +min-keycode+)
	    (setf (aref response 35) +max-keycode+)
	    #+nil (setf (request-integer response 36 4 :little-endian t) 0) ; unused
	    (dotimes (i (length +server-vendor+))
	      (setf (aref response (+ 40 i))
		    (char-code (aref +server-vendor+ i))))
	    (loop for i from 0 below (length *pixmap-formats*)
		  for format in *pixmap-formats*
		  with position = (+ pixmap-data-start (* 8 i))
		  do (progn
		       (setf (aref response (+ position 0)) (first format))
		       (setf (aref response (+ position 1)) (second format))
		       (setf (aref response (+ position 2)) (third format))))
	    ;; FIXME: Add screens here.
	    #+nil (format t "~A~%" response)
	    )
	  (progn
	    ;; FIXME: Need a big-endian version of the above.
	    ;; Should probably introduce some packet creation macrology.
	    (format t "Big-endian case not implemented.~%")
	    ))
      (send-packet network-client response))
    ))

(defun clxs-authorize-client (client packet)
  (declare (ignorable client packet))
  t)

(defun clxs-initial-negotiation (client packet)
  (let ((little-endian (= (aref packet 0) #x6c)))
    (let* ((auth-name-length (if little-endian
				 (request-integer packet 6 2 :little-endian t)
				 (request-integer packet 6 2)))
	   (auth-data-length (if little-endian
				 (request-integer packet 8 2 :little-endian t)
				 (request-integer packet 8 2)))
	   (final-length (+ 12
			    (logand -4 (+ 3 auth-name-length))
			    (logand -4 (+ 3 auth-data-length)))))
      #+(or) (format t "bs ~X nl ~A dl ~A~%" (aref packet 0) auth-name-length auth-data-length)
      (setf (network-client-packet-size client) final-length)
      
      (when (= final-length (network-client-packet-size client))
	(if (clxs-authorize-client client packet)
	    (progn
	      (clxs-initialize-client-connection client packet)
	      (network-client-packet-complete client)
	      ;; Prepare for first request packet.
	      (setf (network-client-packet-size client) 4))
	    (progn
	      (send-authfail-message client
				     "Server not implemented."
				     little-endian)
	      (network-client-disconnect client)))))))

(defun clxs-connect-callback (server)
  (let ((client (network-server-accept server)))
    (when client
      ;; client connection
      (setf (network-client-packet-size client) 12)
      (setf (network-client-packet-received-callback client)
	    (symbol-function 'clxs-initial-negotiation)))))

(defun start-clxs-server (&key (display 1))
  (setf *server*
	(make-network-server #(127 0 0 1) (+ display 6000)
			     :mp-style :serve-event
			     :connect-callback #'clxs-connect-callback))
  (reset-resource-database)
  (reset-atom-database)
  (network-server-start *server*))

(defun stop-clxs-server ()
  (network-server-stop *server*))

;; Hackety-hack. The below probably belong elsewhere.
#|
(define-x-request get-property (:opcode 20)
    ((opcode :opcode :value 20)
     (delete :bool)
     (length :length :value 6)
     (window :window)
     (property :atom)
     (type :atom-or-zero)
     (long-offset :u32)
     (long-length :u32))
  (declare (ignorable delete long-offset long-length))
  ;; FIXME: Implement.
  (protocol-error :implementation))
|#

#|
(define-x-request get-input-focus (:opcode 43)
    ((opcode :opcode :value 43)
     (unused :u8)
     (length :length :value 1))
  (declare (ignore unused))
  (format t "Get input focus.~%"))
|#

(define-x-request create-gc (:opcode 55)
    ((opcode :opcode :value 55)
     (unused :u8)
     (length :length :value (+ 4 (logcount value-mask)))
     (gcid :new-resource-id)
     ;; FIXME: Next should be :drawable, not :u32.
     ;; Is :u32 because no root window yet.
     (drawable #+nil :drawable :u32)
     (value-mask :u32 :typecheck '(unsigned-byte 23)))
  (declare (ignore unused))
  ;; FIXME: Implement properly.
  (setf (x-resource gcid) (make-instance 'gcontext-resource)))

(define-x-request free-gc (:opcode 60)
    ((opcode :opcode :value 60)
     (unused :u8)
     (length :length :value 2)
     (gc :gcontext))
  (declare (ignore unused))
  (format t "Free gcontext ~A~%" gc))

(define-x-request query-extension (:opcode 98)
    ((opcode :opcode :value 98)
     (unused :u8)
     (length :length :value (+ 2 (ash (+ 3 name-length) -2)))
     (name-length :u16))
  (declare (ignore unused))
  (let ((name (make-string name-length))
	(response (make-array 32 :element-type '(unsigned-byte 8)
			      :initial-element 0)))
    (dotimes (i name-length)
      (setf (aref name i) (code-char (aref request (+ 8 i)))))
    (format t "QueryExtension: ~A~%" name)

    (setf (aref response 0) 1)
    (if (eq (client-state-byte-order client) :lsb-first)
	(setf (request-integer response 2 2 :little-endian t) (client-state-request-number client))
	(setf (request-integer response 2 2) (client-state-request-number client)))
    (send-packet (client-state-network-client client) response)))

;;; EOF