Pierre R. Mai
d9cf8a6965
account the server we are servicing, so that each server only sees and creates request/response classes he knows he can handle. This also makes it possible to add request/response classes in a running system, and to run servers of different versions side-by-side in an image without affecting each other...
146 lines
5.3 KiB
Common Lisp
146 lines
5.3 KiB
Common Lisp
;;;; 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))
|