;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
;;;; This is copyrighted software.  See documentation for terms.
;;;; 
;;;; server.cl --- Basic HTTP Server definition
;;;; 
;;;; Checkout Tag: $Name$
;;;; $Id$

(in-package :CLASH)

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

(defclass http-server ()
  ((namespace :initarg :namespace :accessor http-server-namespace)))

(defgeneric export-resource (server url resource-class &rest initargs)
  (:documentation
   "Create an instance of the given `resource-class' using the
supplied `initargs', and add the created resource to the namespace of
the given `server' at the given `url' and return it."))

(defmethod export-resource
    ((server http-server) url resource-class &rest initargs)
  (namespace-add-url (http-server-namespace server)
		     (ctypecase url
		       (url url)
		       (string (parse-url-from-string url)))
		     (apply #'make-instance resource-class initargs)))

(defgeneric serve-connection (server connection)
  (:documentation
   "Let the server serve the connection.  The
server is responsible for closing the connection on return.  Methods
on SERVE-CONNECTION may, but are not forced to, use the generic
functions READ-REQUEST, SERVE-REQUEST and WRITE-RESPONSE to serve the
connection.  Likewise the server is allowed and not forced to use the
generic function handle-server-error to handle server errors."))

(defgeneric read-request (server connection)
  (:method :before (server connection)
	   (declare (ignorable server))
	   (setf (connection-state connection) :read-request))
  (:method :after (server connection)
	   (declare (ignorable server))
	   (setf (connection-state connection) :processing-request))
  (:documentation "Read a request from the connection."))

(defgeneric get-request-class-using-server (server version)
  (:documentation
   "Based on the version given, return the appropriate class for the
request."))

(defgeneric serve-request (server request)
  (:documentation
   "Let the server handle the request, creating a valid response
object that is to be returned."))

(defgeneric create-response-using-server
    (server request status-code &rest args)
  (:documentation "Create an apropriate response object for server and
request, using the detailed information provided by the resource, via
CREATE-RESPONSE.  A server must implement apropriate methods for this
generic function, to ensure conformant generation of response messages."))

(defgeneric get-response-class-using-server (server request)
  (:documentation
   "Return the class to be used in creating the response object based
on the server and the class of the request object passed.  This shall
be used by `create-response-using-server' to determine the class to be
passed to `make-instance'."))

(defgeneric write-response (server connection response)
  (:method :before (server connection response)
	   (declare (ignorable server response))
	   (setf (connection-state connection) :write-request))
  (:method :after (server connection response)
	   (declare (ignorable server response))
	   (setf (connection-state connection) :idle))
  (:documentation
   "Forward the calculated response object to the connection."))

(defgeneric write-response-to-request (server connection response)
  (:method :before (server connection response)
	   (declare (ignorable server response))
	   (setf (connection-state connection) :write-request))
  (:method :after (server connection response)
	   (declare (ignorable server response))
	   (setf (connection-state connection) :idle))
  (:documentation
   "Forward the calculated response object to the connection."))



(defgeneric handle-server-error (server connection condition)
  (:documentation
   "Handle the condition that occurred while server served the given
connection."))

(defmacro with-server-handler ((server connection) &body body)
  (let ((server-sym (gensym))
	(connection-sym (gensym)))
    `(let ((,server-sym ,server)
	   (,connection-sym ,connection))
       (catch 'exit-connection
	 (handler-bind ((error #'(lambda (condition)
				   (handle-server-error
				    ,server-sym
				    ,connection-sym
				    condition))))
	   ,@body)))))

(defgeneric server-product-info (server)
  (:documentation
   "Return a list of Product-Info strings suitable for the HTTP
Server Response-Header."))

(defmethod server-product-info (server)
  (declare (ignore server))
  ;; Default for people too lazy to adjust
  (load-time-value
   (list "CLASH/1.0"
	 (format nil "(~A)"
		 (delete #\( (remove #\) (lisp-implementation-type)))))
   t))

;;; Simple Server

(defclass simple-http-server (http-server)
  ())

(defmethod serve-connection ((server simple-http-server) connection)
  (with-server-handler (server connection)
    (let* ((request (read-request server connection))
	   (response (serve-request server request)))
      (write-response server connection response)))
  (close-connection connection))

(defmethod read-request ((server simple-http-server) connection)
  (parse-request server connection))

(defmethod serve-request ((server simple-http-server) request)
  (let ((resource (namespace-lookup-url (http-server-namespace server)
					(request-url request))))
    (unless resource
      (error 'clash-error :code +HTTP-Code-Not-Found+))
    (access-resource resource request)))

(defmethod write-response ((server simple-http-server) connection response)
  (princ response (connection-stream connection)))

(defmethod create-response-using-server
    ((server simple-http-server) request status-code &rest args)
  (apply #'make-instance
	 (get-response-class-using-server server request)
	 :server server
	 :request request
	 :status-code status-code
	 args))

;;; Basic 0.9 server

(defclass http-server/0.9 (simple-http-server)
  ()
  (:default-initargs :namespace (make-instance 'hierarchical-namespace)))

(defmethod get-request-class-using-server ((server http-server/0.9) version)
  (declare (ignore version))
  (find-class 'request/0.9))

(defmethod write-response :after ((server http-server/0.9) connection response)
  (declare (ignorable server response))
  (setf (connection-state connection) :finished))

(defmethod get-response-class-using-server ((server http-server/0.9) request)
  (declare (ignore request))
  (find-class 'response/0.9))

(defmethod handle-server-error ((server http-server/0.9) connection condition)
  (ignore-errors
    (let ((response (make-instance
		     'response/0.9
		     :server server
		     :status-code
		     +HTTP-Code-Internal-Server-Error+
		     :entity
		     (make-instance 'string-entity
				    :body
				    (format nil
					    "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>500 Internal Server Error</TITLE>~%</HEAD>~%<BODY>~%<H1>Internal Server Error</H1>~%<P>An internal server error occured:</P>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>" condition)))))
      (write-response server connection response)))
  (throw 'exit-connection nil))


;;;; HTTP/1.0

(defclass http-server/1.0 (simple-http-server)
  ()
  (:default-initargs :namespace (make-instance 'hierarchical-namespace)))

(defmethod get-request-class-using-server
    ((server http-server/1.0) (version (eql (get-http-version 0 9))))
  (find-class 'request/0.9))

(defmethod get-request-class-using-server
    ((server http-server/1.0) (version null))
  (find-class 'request/0.9))

(defmethod get-request-class-using-server
    ((server http-server/1.0) version)
  (if (= 1 (http-version-major version))
      (find-class 'request/1.0)
      (error 'clash-error :code +HTTP-Code-HTTP-Version-Not-Supported+)))

(defmethod get-response-class-using-server
    ((server http-server/1.0) (request request/0.9))
  (find-class 'response/0.9))

(defmethod get-response-class-using-server
    ((server http-server/1.0) (request request/1.0))
  (find-class 'response/1.0))

(defmethod handle-server-error ((server http-server/1.0) connection condition)
  (ignore-errors
    (let ((response
	   (typecase condition
	     (clash-error
	      (apply #'make-instance
		     'response/1.0
		     :server server
		     :status-code (clash-error-code condition)
		     :entity
		     (apply #'make-instance
			    'string-entity
			    :body
			    (format nil "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>~3D ~A</TITLE>~%</HEAD>~%<BODY>~%<H1>~2:*~3D ~A</H1>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>"
				    (clash-error-code condition)
				    (HTTP-Code-Description (clash-error-code condition))
				    condition)
			    (clash-error-entity-initargs condition))
		     (clash-error-response-initargs condition)))
	     (error
	      (make-instance
	       'response/1.0
	       :server server
	       :status-code
	       +HTTP-Code-Internal-Server-Error+
	       :entity
	       (make-instance 'string-entity
			      :body
			      (format nil
				      "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>500 Internal Server Error</TITLE>~%</HEAD>~%<BODY>~%<H1>Internal Server Error</H1>~%<P>An internal server error occured:</P>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>" condition)))))))
      (write-response server connection response)))
  (throw 'exit-connection nil))