;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
;;;; This is copyrighted software.  See documentation for terms.
;;;; 
;;;; messages.cl --- HTTP Request and Response messages
;;;; 
;;;; Checkout Tag: $Name$
;;;; $Id$

(in-package :CLASH)

;;;; %File Description:
;;;; 
;;;; 
;;;; 

(defclass http-message ()
  ((server :initarg :server :reader http-message-server
	   :documentation "The server this message belongs to.")))

(defgeneric http-message-version (message)
  (:documentation "Returns the HTTP-Version of the given message."))

(defgeneric render-http-message (message stream)
  (:documentation "Render the given message on the stream."))

(defmethod print-object ((object http-message) stream)
  (if (or *print-readably* *print-escape*)
      (call-next-method)
      (render-http-message object stream)))

(defgeneric header-exists-p (message header)
  (:documentation
   "Returns true if the given header exists and is filled-in in the
given message."))

(defmethod header-exists-p (message header)
  (and (slot-exists-p message header) (slot-boundp message header)))

(defgeneric header-value (message header)
  (:documentation
   "If the given header exists and is available, as determined by
`header-exists-p', it's value is returned.  Otherwise an error is
raised."))

(defmethod header-value (message header)
  (slot-value message header))

(defmacro with-headers (specs message &body body)
  "This is the equivalent of with-slots on http-messages, using header-value."
  (loop with message-var = (gensym)
	for spec in specs
	for symbol = (if (consp spec) (first spec) spec)
	for header = (if (consp spec) (second spec) spec)
	collect `(,symbol (header-value ,message-var ',header)) into clauses
	finally
	(return 
	  `(let ((,message-var ,message))
	     (symbol-macrolet ,clauses ,@body)))))

;;;; Requests

(defclass request (http-message)
  ((stream :initarg :stream :reader request-stream)
   (method :initarg :method :reader request-method)
   (url :initarg :url :reader request-url)))

;;;; Responses

(defclass response (http-message)
  ((request :initarg :request :initform nil :reader response-request)
   (status-code :initarg :status-code :reader response-status-code)))

;;;; Creating responses for requests:
(defgeneric create-response (request status-code &rest args))

(defmethod create-response ((request request) status-code &rest args)
  (apply #'create-response-using-server
	 (http-message-server request)
	 request
	 status-code
	 args))

;;;; Request parsing framework
(defgeneric parse-request (server stream)
  (:documentation
   "Parse a request from the given stream, returning the created
request object, which references the given server."))

(defmethod parse-request (server stream)
  (multiple-value-bind (method url version)
      (parse-request-line stream)
    (let ((request (make-instance
		    (get-request-class-using-server server version)
		    :stream stream
		    :server server
		    :method method
		    :url url)))
      (parse-request-remainder request stream)
      request)))

(defun parse-request-line (stream)
  "Parse a valid request-line from the stream, returning the method,
url and http-version as a result."
  (let ((request-line
	 (loop for line = (read-http-line stream)
	       while (and line (zerop (length line)))
	       finally
	       (if line
		   (return line)
		   (error 'simple-clash-error
			  :code +HTTP-Code-Bad-Request+
			  :format-control "Got no valid request-line.")))))
    (flet ((report-error (fmt &rest args)
	     (error 'simple-clash-error
		    :code +HTTP-Code-Bad-Request+
		    :format-control "~? in Request ~S."
		    :format-arguments (list fmt args request-line))))
      (loop with method-end = nil
	    with url-end = nil
	    with state = :in-method
	    for pos from 0 below (length request-line)
	    for char = (char request-line pos)
	    do
	    (case state
	      (:in-method
	       (when (char= char #\Space)
		 (setq method-end pos
		       state :in-method-delimiter)))
	      (:in-method-delimiter
	       (setq state :in-url))
	      (:in-url
	       (when (char= char #\Space)
		 (setq url-end pos
		       state :in-url-delimiter)))
	      (:in-url-delimiter
	       (setq state :in-http-version))
	      (:in-http-version
	       (unless (find char "HTP/0123456789.")
		 (report-error "Strange HTTP-Version field"))))
	    finally
	    (case state
	      ((:in-method :in-method-delimiter)
	       (report-error "No Request-URI"))
	      (:in-url-delimiter
	       (report-error "No HTTP-Version in a non-simple Request"))
	      ((:in-url :in-http-version)
	       (return
		 (values (get-method-symbol (subseq request-line 0 method-end))
			 (parse-url-from-string
			  (subseq request-line (1+ method-end) url-end)
			  :base "http")
			 (if url-end
			     (parse-http-version
			      (subseq request-line (1+ url-end)))
			     nil)))))))))

(defgeneric parse-request-remainder (request stream)
  (:documentation
   "Parse the remainder of the request from the given stream, and
validate the whole request, including method and url."))

;;;; Utility macros for HTTP/1.0 and larger

(defun parse-http-headers (stream)
  "Parse all HTTP headers from the stream up to the end of the header
indicated by an empty line and return them as a a-list of header/value
string pairs for further parsing."
  (loop for in-line = (read-http-line stream)
 	while (and in-line (not (zerop (length in-line))))
	collect
	(let ((header-end (position #\: in-line)))
	  (unless header-end
	    (error 'simple-clash-error
		   :code +HTTP-Code-Bad-Request+
		   :format-control "Missing header separator in line ~S."
		   :format-arguments (list in-line)))
	  (loop with header = (subseq in-line 0 header-end)
		for line = (subseq in-line (1+ header-end))
		then (read-http-line stream)
		for value = (string-trim '(#\Space #\Tab) line)
		then (concatenate 'string value " "
				  (string-trim '(#\Space #\Tab) line))
		for next-char = (peek-char nil stream nil #\@)
		while (or (char= next-char #\Space) (char= next-char #\Tab))
		finally (return (cons header value))))))

(defun merge-multiple-http-headers (header-alist)
  "Merge multiply occurring headers into single headers."
  ;; TODO: Implement properly and tune.  Since duplicated headers
  ;; occur rarely in practice (only allowable on list headers), this
  ;; should execute quickly and without consing for non-duplicate
  ;; headers, and work reasonably for merging duplicates.
  header-alist)

(defmacro process-http-headers ((header value) headers &body clauses)
  "Process the headers a-list produced by the `headers' form, as
specified by the clauses, and return as values the list of processed
headers and the rest a-list of unprocessed headers.

The clauses are of the form ((string key) . body).  For each header in
the a-list, if a clause with a matching (string-equal) string form,
which is evaluated, is found, then body is evaluated in an environment
where the variables named via `header' and `value' are bound to the
relevant header and value strings, and the result of evaluating key
and the implicit progn `body' are appended to the list of processed
headers.  An empty body will evaluate to the value of `value'.

If no matching clause is found, then a cons of header and value string
is appended to the list of unprocessed headers."

  (let ((processed (gensym))
	(remaining (gensym))
	(cond-clauses
	 (loop for (clause . body) in (mapcar #'(lambda (x)
						  (if (consp x)
						      x
						      (cons x nil)))
					      clauses)
	       for string = (string (if (consp clause) (car clause) clause))
	       for key = (if (and (consp clause) (cadr clause))
			     (cadr clause)
			     (intern (string-upcase string) "KEYWORD"))
	       collect `((string-equal ,header ,string)
			 (list ,key (progn ,value ,@body))))))
    `(loop for (,header . ,value) in ,headers
           if (cond ,@cond-clauses) nconc it into ,processed
           else collect (cons ,header ,value) into ,remaining
           finally (return (values ,processed ,remaining)))))

(defmacro render-slots ((obj stream) &rest clauses)
  (loop with obj-sym = (gensym)
	with stream-sym = (gensym)
	for (slot-spec string . body) in clauses
	for slot = (if (consp slot-spec) (car slot-spec) slot-spec)
	for slot-var = (if (consp slot-spec) (cadr slot-spec) slot-spec)
	collect
	`(when (header-exists-p ,obj-sym (quote ,slot))
	   (with-headers ((,slot-var ,slot)) ,obj-sym
	     (write-string ,string ,stream-sym)
	     (write-char #\: ,stream-sym)
	     (write-char #\Space ,stream-sym)
	     ,@body
	     (write-char #\Return ,stream-sym)
	     (write-char #\Newline ,stream-sym)))
	into clause-list
	finally
	(return `(let ((,stream-sym ,stream)
		       (,obj-sym ,obj))
		   ,@clause-list))))

;;;; HTTP/0.9

(defclass request/0.9 (request)
  ((version :allocation :class :initform (get-http-version 0 9)
	    :reader http-message-version)))

(defmethod parse-request-remainder ((request request/0.9) stream)
  (declare (ignore stream))
  (unless (eq (request-method request) :GET)
    (error 'simple-clash-error
	   :code +HTTP-Code-Bad-Request+
	   :format-control
	   "Bad Request Method ~A for the request's HTTP-Version ~A."
	   :format-arguments (list (request-method request)
				   (http-message-version request))))
  t)

(defmethod request-entity ((request request/0.9))
  nil)

(defclass response/0.9 (response)
  ((version :allocation :class :initform (get-http-version 0 9)
	    :reader http-message-version)
   (entity :initarg :entity :reader http-message-entity)))

(defmethod initialize-instance :after
    ((instance response/0.9) &rest initargs &allow-other-keys)
  t)

(defmethod render-http-message ((message response/0.9) stream)
  (render-entity-body (http-message-entity message) stream))

;;;; HTTP/1.0

(defclass request/1.0 (request)
  ((version :allocation :class :initform (get-http-version 1 0)
	    :reader http-message-version)
   (authorization :initarg :authorization :reader request-authorization)
   (cookie :initarg :cookie :reader request-cookie)
   (date :initarg :date :reader request-date)
   (from :initarg :from :reader request-from)
   (if-modified-since :initarg :if-modified-since
		      :reader request-if-modified-since)
   (pragma :initarg :pragma :reader request-pragma)
   (referer :initarg :referer :reader request-referer)
   (user-agent :initarg :user-agent :reader request-user-agent)
   (entity)
   (entity-headers :initarg :entity-headers
		   :initform nil)))

(defmethod shared-initialize :after
    ((instance request/1.0) slots &rest args &key host)
  (declare (ignore slots args))
  (when host
    (setf (slot-value instance 'url)
	  (merge-urls (slot-value instance 'url) host))))

(defgeneric compute-request-initargs (request headers)
  (:documentation
   "Given a parsed HTTP header-list, compute the initargs that will be
used to call `reinitialize-instance'."))

(defmethod compute-request-initargs ((request request/1.0) headers)
  (multiple-value-bind (initargs rest)
      (process-http-headers (h v) headers
	:authorization
	:date
	:from
	:if-modified-since
	:pragma
	(:referer (parse-url-from-string v))
	:user-agent
	(:cookie (parse-key-value-list v :list-delimiter #\;))
	(:host (parse-url-from-string (concatenate 'string "http://" v))))
    (list* :entity-headers rest initargs)))

(defmethod parse-request-remainder ((request request/1.0) stream)
  (let* ((headers (parse-http-headers stream))
	 (initargs (compute-request-initargs request headers)))
    (apply #'reinitialize-instance request initargs)
    t))

(defmethod request-entity ((request request/1.0))
  (if (slot-boundp request 'entity)
      (slot-value request 'entity)
      (setf (slot-value request 'entity)
	    (read-request-entity request))))

(defmethod read-request-entity ((request request/1.0))
  (let* ((headers (slot-value request 'entity-headers))
	 (length-cons (assoc "content-length" headers :test #'string-equal))
	 (length (and length-cons (parse-integer (cdr length-cons))))
	 (stream (request-stream request)))
    (when length
      (let ((buffer (make-string length)))
	(read-sequence buffer stream)
	(make-instance 'string-entity :content-length length
		       :content-type (cdr (assoc "content-type" headers
						 :test #'string-equal))
		       :body buffer)))))

(defclass response/1.0 (response)
  ((version :allocation :class :initform (get-http-version 1 0)
	    :reader http-message-version)
   (date :initarg :date :reader response-date)
   (location :initarg :location :reader response-location)
   (pragma :initarg :pragma :reader response-pragma)
   (set-cookie :initarg :set-cookie :reader response-set-cookie)
   (entity :initarg :entity :reader http-message-entity)))

(defmethod render-http-message ((message response/1.0) stream)
  (format stream "~A ~D ~A" (http-message-version message)
	  (response-status-code message)
	  (HTTP-Code-Description (response-status-code message)))
  (http-terpri stream)
  (render-slots (message stream)
    (date "Date"
      (format stream "~A" date))
    (location "Location"
      (format stream "~A" location))
    (pragma "Pragma"
      (format stream "~{~A~^, ~:}" pragma))
    (set-cookie "Set-Cookie"
      (format stream "~:{~A~@[=~A~]~^;~:}" set-cookie)))
  (when (slot-boundp message 'entity)
    (render-entity-headers (http-message-entity message) stream)
    (http-terpri stream)
    (unless (and (response-request message)
		 (eq (request-method (response-request message)) :HEAD))
      (render-entity-body (http-message-entity message) stream))))