257 lines
9.0 KiB
Common Lisp
257 lines
9.0 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 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))
|