; Copyright (C) 2006 by Rüdiger Sonderfeld

;(asdf:oos 'asdf:load-op :fiveam)

; TODO:
;  * move macros and stuff to different file
;  * type declarations
;  * Unit Tests

(defpackage :fcgi
  (:use :common-lisp :sb-bsd-sockets :it.bese.FiveAM)
  (:export "LS-READER" "ACCEPT" "SETUP-ENVIRONMENT" "WRITE-STDOUT"
	   "WRITE-STDERR" "END-REQUEST"))
;  (:description "Implementation of the FastCGI 1.0 Protocol specifications."))

(in-package :fcgi)

(defun to-string (n)
  (format nil "~A" n))

;; Binary Mapper
(defun compose-2-to (sym count)
  (values
   `(setf (ldb (byte 8 8) (,sym obj)) (aref byte-data ,count)

	  (ldb (byte 8 0) (,sym obj)) (aref byte-data ,(incf count)))
   (1+ count)))

(defun compose-2-from (sym count)
  (values
   `(setf (aref byte-data ,count) (ldb (byte 8 8) (,sym obj))
	  (aref byte-data ,(incf count)) (ldb (byte 8 0) (,sym obj)))
   (1+ count)))

(defun compose-4-to (sym count)
  (values
   `(setf (ldb (byte 8 24) (,sym obj)) (aref byte-data ,count)
	  (ldb (byte 8 16) (,sym obj)) (aref byte-data ,(incf count))
	  (ldb (byte 8  8) (,sym obj)) (aref byte-data ,(incf count))
	  (ldb (byte 8  0) (,sym obj)) (aref byte-data ,(incf count)))
   (1+ count)))

(defun compose-4-from (sym count)
  (values
   `(setf (aref byte-data ,count) (ldb (byte 8 24) (,sym obj))
	  (aref byte-data ,(incf count)) (ldb (byte 8 16) (,sym obj))
	  (aref byte-data ,(incf count)) (ldb (byte 8  8) (,sym obj))
	  (aref byte-data ,(incf count)) (ldb (byte 8  0) (,sym obj)))
   (1+ count)))

(defun simple-set-to (sym count)
  (values
   `(setf (,sym obj) (aref byte-data ,count))
   (1+ count)))

(defun simple-set-from (sym count)
  (values
   `(setf (aref byte-data ,count) (,sym obj))
   (1+ count)))

(defmacro binary-mapper (name &rest mapping)
  "Creates functions and a class for mapping a array of binary data to
   an object of that class.

   name is the name of the class. The corresponding functions are
   map-to-<name> and map-from-<name>. map-to-<name> takes an byte array
   as parameter and returns an object with the byte data mapped and
   map-from-<name> takes an object as parameter and returns a byte array.

   mapping are the name of the elements of the class. They can be just a
   symbol (the corresponding name and accessor of the class-element) or a
   list with the name first and as second parameter a composition type
   that allows you to map several bytes to one value.

   At the moment compose-2 and compose-4 are supported:
   compose-2 maps 2 bytes to a value anc compose-4 4 bytes.

    e.g.
   (struct-mapper fcgi request type (content-length 'compose-2))
  "
  (let ((type-in 1) (to-in 2) (from-in 3) (size-in 4)
	(type-mapper '(#(compose-2
			 '(unsigned-byte 16)
			 compose-2-to
			 compose-2-from
			 2)
		       #(compose-4
			 '(unsigned-byte 32)
			 compose-4-to
			 compose-4-from
			 4))))
    `(progn
       (defclass ,name ()
	 ,(mapcar #'(lambda (n)
		      (if (listp n)
			  (list (first n) :initform 0 :accessor (first n)
				:initarg (intern (symbol-name (first n))
						 :keyword)
				:type (aref (find-if #'(lambda (te)
							 (eq (aref te 0)
							     (second n)))
						     type-mapper)
					    type-in))
			  (list n :initform 0 :accessor n
				:initarg (intern (symbol-name n) :keyword)
				:type '(unsigned-byte 8))))
		  mapping))
       (defun ,(intern (format nil "MAP-TO-~A" name)) (byte-data)
	 (let ((obj (make-instance ',name)))
	   ,@(let ((count 0))
		  (mapcar #'(lambda (n)
			      (if (listp n)
				  (multiple-value-bind (ret ptr)
				      (funcall
				       (aref (find-if #'(lambda (te)
							  (eq (aref te 0)
							      (second n)))
						      type-mapper)
					     to-in)
				       (first n) count)
				    (setf count ptr)
				    ret)
				  (multiple-value-bind (ret ptr)
				      (simple-set-to n count)
				    (setf count ptr)
				    ret)))
			  mapping))
	   obj))
       (defun ,(intern (format nil "MAP-FROM-~A" name)) (obj)
	 (let* ((bytes ,(loop for i in mapping
			      sum (if (listp i)
				      (aref
				       (find-if #'(lambda (te)
						    (eq (aref te 0)
							(second i)))
						type-mapper)
				       size-in)
				      1) into size
			      finally (return size)))
		(byte-data (make-array bytes :element-type '(unsigned-byte 8))))
	   ,@(let ((count 0))
		  (mapcar #'(lambda (n)
			      (if (listp n)
				  (multiple-value-bind (ret ptr)
				      (funcall
				       (aref (find-if #'(lambda (te)
							  (eq (aref te 0)
							      (second n)))
						      type-mapper)
					     from-in)
				       (first n) count)
				    (setf count ptr)
				    ret)
				  (multiple-value-bind (ret ptr)
				      (simple-set-from n count)
				    (setf count ptr)
				    ret)))
			  mapping))
	   byte-data))
       (defconstant ,(intern (format nil "+~A-SIZE+" name))
			      ,(loop for i in mapping
			      sum (if (listp i)
				      (aref
				       (find-if #'(lambda (te)
						    (eq (aref te 0)
							(second i)))
						type-mapper)
				       size-in)
				      1) into size
			      finally (return size))))))

(define-condition not-enough-byted-read (error)
  ((bytes-read :initarg :bytes-read :reader bytes-read)
   (byted-required :initarg :bytes-required :reader bytes-required)))
; Should rather loop-read until enough bytes read!

(define-condition begin-request-on-active-request (error)
  ((request-id :initarg :request-id :reader request-id)))

(define-condition fastcgi-version-not-supported (error)
  ((version :initarg :version :reader version)))

(define-condition unknown-type (error) ; should rather report error to httpd
  ((conn-type :initarg :conn-type :reader conn-type)))

(defclass fcgi-conn ()
  ((active :initform nil :initarg :active :accessor active)
   (request-id :initform nil :initarg :request-id :accessor request-id)
   (connection-fd :initarg :connection-fd :initform nil :accessor connection-fd)
   (role :initarg :role :accessor role)
   (env :initarg :env :initform nil :accessor environment)
   (stdin :initarg :stdin :accessor stdin)
   (keep-conn :initarg :keep-conn :initform nil :accessor keep-conn)))

(defconstant +fcgi-max-connections+ 16)

(defclass fcgi-main ()
  ((socket :accessor socket)
   (request-ids :initform (make-array #.+fcgi-max-connections+
				      :initial-element (make-instance
							'fcgi-conn)
				      :element-type 'fcgi-conn) :type 'array
				      :accessor request-ids)))

(defmethod local-socket ((fcgi fcgi-main) socket-path)
  "Sets up a LOCAL-SOCKET (UNIX-SOCKET)"
  (with-accessors ((sock socket)) fcgi
    (setf sock (make-instance 'sb-bsd-sockets:local-socket :type :stream))
    (sb-bsd-sockets:socket-bind sock socket-path)
    (sb-bsd-sockets:socket-listen sock 3)))

(binary-mapper fcgi-header
	       version
	       conn-type
	       (request-id compose-2)
	       (content-length compose-2)
	       padding-length
	       reserved)

(defconstant +fcgi-begin-request+ 1)
(defconstant +fcgi-abort-request+ 2)
(defconstant +fcgi-end-request+ 3) 
(defconstant +fcgi-params+ 4)
(defconstant +fcgi-stdin+ 5)
(defconstant +fcgi-stdout+ 6)
(defconstant +fcgi-stderr+ 7)
(defconstant +fcgi-data+ 8)
(defconstant +fcgi-get-values+ 9)
(defconstant +fcgi-get-values-result+ 10)
(defconstant +fcgi-unkown-type+ 11)
(defconstant +fcgi-maxtype+ 11)
(defconstant +fcgi-null-request-id+ 0)
(defconstant +fcgi-version+ 1)

(defun read-fcgi-header (conn)
  "reads byte-data from conn and maps it to a fcgi-header"
  (let ((byte-data
	 (make-array +fcgi-header-size+ :element-type '(unsigned-byte 8))))
    (multiple-value-bind (buffer length addr)
	(sb-bsd-sockets:socket-receive conn byte-data nil)
      (declare (ignore addr))
      (if (= length +fcgi-header-size+)
	  (map-to-fcgi-header buffer)
	  (error 'not-enough-bytes-read :byted-read length
		 :bytes-required +fcgi-header-size+)))))

(binary-mapper fcgi-begin-request-body
	       (role compose-2)
	       flags
	       reserved0 reserved1 reserved2 reserved3 reserved4)

(defconstant +fcgi-keep-conn+ 1)
(defconstant +fcgi-responder+ 1)
(defconstant +fcgi-authorizer+ 2)
(defconstant +fcgi-filter+ 3)

(defmethod begin-request ((fcgi fcgi-main) header conn)
  (let ((byte-data (make-array (+ (content-length header)
				  (padding-length header))
			       :element-type '(unsigned-byte 8))))
    (multiple-value-bind (buffer length addr)
	(sb-bsd-sockets:socket-receive conn byte-data nil)
      (declare (ignore addr)) ; TODO: Check addr for WEB_SERVER_ADDRS (see Spec)
      (if (>= length +fcgi-begin-request-body-size+)
	  (let ((begin-req-body (map-to-fcgi-begin-request-body buffer)))
	    (when (active (aref (request-ids fcgi) (request-id header)))
	      (error 'begin-request-on-active-request
		     :request-id (request-id header)))
	      (setf (aref (request-ids fcgi) (request-id header))
		    (make-instance 'fcgi-conn :active t
				   :request-id (request-id header)
				   :connection-fd conn
				   :role (role begin-req-body)
				   :keep-conn (logand (flags begin-req-body)
						      +fcgi-keep-conn+))))
	  (error 'not-enough-bytes-read :bytes-read length
		 :bytes-required +fcgi-begin-request-body-size+)))))

(binary-mapper fcgi-end-request-body
	       (app-status compose-4)
	       protocol-status
	       reserved0 reserved1 reserved2)

(defconstant +fcgi-request-complete+ 0)
(defconstant +fcgi-cant-mpx-conn+ 1)
(defconstant +fcgi-overloaded+ 2)
(defconstant +fcgi-unkown-role+ 3)

(binary-mapper fcgi-unkown-type-body
	       conn-type
	       reserved0 reserved1 reserved2 reserved3 reserved4 reserved5
	       reserved6)

; UNTESTED
(defmethod unknown-type ((fcgi fcgi-main) header conn)
  "Sends an UNKNOWN_TYPE-Message to the httpd"
  (let ((ret-header (make-instance 'fcgi-header
				   :version +fcgi-version+
				   :conn-type +fcgi-unkown-type+
				   :request-id +fcgi-null-request-id+
				   :content-length +fcgi-unkown-type-body-size+
				   :padding-length 0))
	(body (make-instance 'fcgi-unkown-type-body
			     :conn-type (conn-type header))))
    (sb-bsd-sockets:socket-send conn
				(concatenate '(vector (unsigned-byte 8))
					     (map-from-fcgi-header ret-header)
					     (map-from-fcgi-unkown-type-body
					      body))
				nil)))

(defun to-31bit (buffer pos)
  "Converts 4 bytes from buffer beginning at pos into a 31 Bit Fixnum"
  (+ (ash (logand (aref buffer pos) #x7f) 24)
     (ash (aref buffer (1+ pos)) 16)
     (ash (aref buffer (+ 2 pos)) 8)
     (aref buffer (+ 3 pos))))

(defun read-name-value-pairs (buffer &optional (handle-cons #'(lambda (c) c)))
  "Converts Name-Value-Pairs in buffer into a cons and calls handle-cons for
   each (returning a list of the return values of handle-cons) or returns
   a list of cons."
  (loop
     with pos = 0
     with name-length
     with value-length
     until (>= pos (length buffer))
     do (progn
	  (setf name-length (aref buffer pos))
	  (when (= (ash name-length -7) 1) ; 31 bit name-length?
	    (setf name-length (to-31bit buffer pos))
	    (incf pos 3))
	  (setf value-length (aref buffer (incf pos)))
	  (when (= (ash value-length -7) 1) ; 31 bit value-length?
	    (setf value-length (to-31bit buffer pos))
	    (incf pos 3)))
     collect (funcall handle-cons
		      (cons (map 'string #'code-char
				 (subseq buffer (incf pos)
					 (incf pos name-length)))
			    (map 'string #'code-char
				 (subseq buffer pos
					 (incf pos value-length)))))))

(defun length-to-binary (value)
  "Converts value into binary data.

   It either returns an array of 4 byte with 31 bit for value and the first bit
   as a flag set to 1 or returns an array of 1 byte with 7 bit for value and
   the first bit set to 0."
  (if (> value #x7f) ; does length fit into 7 Bit or 31 Bit required?
      (let ((buffer (make-array 4 :element-type '(unsigned-byte 8))))
	(setf (aref buffer 0) (logior (ash value -24) #x80)) ; activate bit 32
	(setf (aref buffer 1) (ash value -16))
	(setf (aref buffer 2) (ash value -8))
	(setf (aref buffer 3) value)
	buffer)
      (make-array 1 :element-type '(unsigned-byte 8)
		  :initial-element value)))

(defun write-name-value-pair (pair)
  "Converts a cons into a Name-Value-Pair."
  (let ((name (car pair)) (value (cdr pair)))
    (concatenate '(vector (unsigned-byte 8))
		 (length-to-binary (length name))
		 (length-to-binary (length value))
		 name
		 value)))

; UNTESTED!
(defmethod get-values-result ((fcgi fcgi-main) header conn)
  "Interpretes a GET_VALUES_RESULT-Message and sends an answer to the httpd"
  (let ((byte-data (make-array (+ (content-length header)
				  (padding-length header))
			       :element-type '(unsigned-byte 8)
			       :fill-pointer (content-length header))))
    (multiple-value-bind (buffer length addr)
	(sb-bsd-sockets:socket-receive conn byte-data nil)
      (declare (ignore addr) (ignore buffer))
      (when (< length (content-length header))
	(error 'not-enough-bytes-read :bytes-read length
	       :bytes-required (content-length header)))
      (let* ((body (reduce 
		    #'(lambda (&optional a b)
			(concatenate 'vector a b))
		    (read-name-value-pairs byte-data
					   #'(lambda (pair)
					       (write-name-value-pair
						(case (car pair)
						  ("FCGI_MAX_CONNS"
						   '("FCGI_MAX_CONNS" .
				      (to-string #.+fcgi-max-connections+)))
						  ("FCGI_MAX_REQS"
						   '("FCGI_MAX_REQS" .
						     "1"))
						  ("FCGI_MPXS_CONN"
						   '("FCGI_MPXS_CONN" .
						     "0"))))))))
	       (ret-header (make-instance 'fcgi-header
					:version +fcgi-version+
					:conn-type +fcgi-get-values-result+
					:request-id +fcgi-null-request-id+
					:content-length (length body)
					:padding-length 0)))
	(sb-bsd-sockets:socket-send conn (concatenate 'vector
						      (map-from-fcgi-header
						       ret-header)
						      body)
						      nil)))))

(defun read-stream (header conn)
  "Reads stream data from conn."
  (loop
      with hdr = header
      with data = nil
      until (= (content-length hdr) 0)
      do
      (progn
     ; read body
	(with-slots (content-length) hdr
	  (let ((byte-data (make-array (+ content-length
					  (padding-length hdr))
				       :element-type '(unsigned-byte 8)
				       :fill-pointer t)))
	    (multiple-value-bind (buffer length addr)
		(sb-bsd-sockets:socket-receive conn byte-data nil)
	      (declare (ignore addr) (ignore buffer))
	      (when (< length content-length)
		(error 'not-enough-bytes-read :bytes-read length
		       :bytes-required content-length)))
	    (setf (fill-pointer byte-data) content-length)
	    (setf data (concatenate 'vector data byte-data))))
    ; read next package header  
	(setf hdr (read-fcgi-header conn)))
      finally (return data)))

(defmethod read-params ((fcgi fcgi-main) header conn)
  "Reads a stream of FCGI_PARAMS packages and initializes the fcgi-conn
   environment"
  (assert (active (aref (request-ids fcgi) (request-id header))))
  (read-name-value-pairs
   (read-stream header conn)
   #'(lambda (pair)
       (push pair (environment
		   (aref (request-ids fcgi) (request-id header)))))))

(defmethod read-stdin ((fcgi fcgi-main) header conn)
  "Reads a stream of FCGI_STDIN packages and sets the fcgi-conn stdin slot"
  (assert (active (aref (request-ids fcgi) (request-id header))))
  (setf (stdin (aref (request-ids fcgi) (request-id header)))
	(read-stream header conn)))

(defmethod read-package ((fcgi fcgi-main) conn)
  "Reads a package from conn and handles it"
  (let ((hdr (read-fcgi-header conn)))
    (unless (= (version hdr) +fcgi-version+)
      (error 'fastcgi-version-not-supported :version (version hdr)))
    (values (conn-type hdr)
	    (case (conn-type hdr)
	      (#.+fcgi-begin-request+ (begin-request fcgi hdr conn))
	      (#.+fcgi-abort-request+ ) ; TODO
	      (#.+fcgi-params+ (read-params fcgi hdr conn))
	      ((#.+fcgi-stdin+ #.+fcgi-data+) (read-stdin fcgi hdr conn))
	      (#.+fcgi-get-values+ (get-values-result fcgi hdr conn))
	      (otherwise 
	       (if (= (request-id hdr) +fcgi-null-request-id+)
		   (unknown-type fcgi hdr conn)
		   (error 'unknown-type :conn-type (conn-type hdr))))))))

(defmethod accept ((fcgi fcgi-main))
  "Handles new Connections"
  (loop do (let ((conn (sb-bsd-sockets:socket-accept (socket fcgi))))
	     (setf (non-blocking-mode conn) t)
	     (multiple-value-bind (pkg-type ret)
		 (read-package fcgi conn)
	       (when (= pkg-type +fcgi-begin-request+)
		 (return ret))))))

(defmethod setup-environment ((fcgi fcgi-main) (conn fcgi-conn))
  "sets up the connection environemnt"
  (with-slots (connection-fd) conn
    (loop do
	 (multiple-value-bind (pkg-type ret)
	     (read-package fcgi connection-fd)
	   (declare (ignore ret))
	   (when (= pkg-type #.+fcgi-params+)
	     (loop-finish))))
    (read-package fcgi connection-fd)))  ; read stdin data if possible

(defmethod end-request ((conn fcgi-conn) app-status
			&optional (protocol-status #.+fcgi-request-complete+))
  "Signals the httpd that the request was finished.

   The value of app-status depends on the role type but is usually the
   unix-style program return value"
  (let ((header (make-instance 'fcgi-header
			       :version +fcgi-version+
			       :conn-type +fcgi-end-request+
			       :request-id (request-id conn)
			       :content-length +fcgi-end-request-body-size+
			       :padding-length 0))
	(body (make-instance 'fcgi-end-request-body
			     :app-status app-status
			     :protocol-status protocol-status)))
    (sb-bsd-sockets:socket-send (connection-fd conn)
				(concatenate '(vector (unsigned-byte 8))
					     (map-from-fcgi-header header)
					     (map-from-fcgi-end-request-body
					      body))
				nil))

  (unless (keep-conn conn)
    (sb-bsd-sockets:socket-close (connection-fd conn)))
  (setf (environment conn) nil)
  (setf (stdin conn) nil)
  (setf (active conn) nil))

(defmethod fcgi-write ((conn fcgi-conn) data type)
  "Sends data to the stream which is specified in `type'.

   `data' can be either of type string or (vector (unsigned-byte 8)).

   This funciton is library intern. Library Users should use write-stdout or
   write-stderr instead!"
  (when (stringp data)
    (setf data (map '(vector (unsigned-byte 8)) #'(lambda (c) (char-code c))
		    data)))
  (let ((header (make-instance 'fcgi-header
			       :version #.+fcgi-version+
			       :conn-type type
			       :request-id (request-id conn)
; TODO: WARNING: This is buggy if data is bigger than #xFFFF bytes.
;       Should send a stream instead!
			       :content-length (length data)
			       :padding-length 0))
	(header0 (make-instance 'fcgi-header
				:version #.+fcgi-version+
				:conn-type type
				:request-id (request-id conn)
				:content-length 0
				:padding-length 0)))
    (sb-bsd-sockets:socket-send (connection-fd conn)
				(concatenate '(vector (unsigned-byte 8))
					     (map-from-fcgi-header header)
					     data
					     (map-from-fcgi-header header0))
				nil)))

(defmethod write-stdout ((conn fcgi-conn) data)
  "Writes data to STDOUT (to the client)"
  (fcgi-write conn data #.+fcgi-stdout+))

(defmethod write-stderr ((conn fcgi-conn) data)
  "Writes data to STDERR (to the error-log)"
  (fcgi-write conn data #.+fcgi-stderr+))

(defun ls-reader (socket-path)
  "FOR TESTING PURPOSE ONLY"
  (let ((fcgi (make-instance 'fcgi-main)))
    (local-socket fcgi socket-path)
    (let ((conn (accept fcgi)))
      (setup-environment fcgi conn)
      (write (stdin conn))
      (let ((env (environment conn)))
	(write-stdout conn
		      (format nil "Content-type: text/html~C~C~C~C<title>ho</title> <p>hallo!</p>~C~C" (code-char 13) (code-char 10) (code-char 13) (code-char 10) (code-char 13) (code-char 10)))
	(write-stderr conn "Hello Err-Log!")
	(end-request conn 0)
	env))))