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

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

(defmethod serve-connection ((server http-server/0.9) 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 http-server/0.9) connection)
  (parse-request server (connection-stream connection)))

(defmethod get-request-class-using-server ((server http-server/0.9) version)
  (get-request-class nil))

(defmethod serve-request ((server http-server/0.9) 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 http-server/0.9) connection response)
  (princ response (connection-stream connection)))

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

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

(defmethod get-response-class-using-server ((server http-server/0.9) request)
  (get-response-class (get-http-version 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 'simple-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))