102 lines
3.3 KiB
Common Lisp
102 lines
3.3 KiB
Common Lisp
;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
|
|
;;;; This is copyrighted software. See documentation for terms.
|
|
;;;;
|
|
;;;; resource.cl --- Definition of a served resource
|
|
;;;;
|
|
;;;; Checkout Tag: $Name$
|
|
;;;; $Id$
|
|
|
|
(in-package :CLASH)
|
|
|
|
;;;; %File Description:
|
|
;;;;
|
|
;;;; A resource is that which is accessed by a client through a server
|
|
;;;; via an URL ;)
|
|
;;;;
|
|
|
|
(defclass resource ()
|
|
())
|
|
|
|
(defgeneric resource-allowed-methods (resource))
|
|
|
|
(defgeneric access-resource (resource request)
|
|
(:argument-precedence-order request resource))
|
|
|
|
(defgeneric access-resource-using-method (resource request method)
|
|
(:argument-precedence-order method request resource))
|
|
|
|
(defmethod access-resource ((resource resource) request)
|
|
(let ((method (request-method request))
|
|
(allowed-methods (resource-allowed-methods resource)))
|
|
(if (member method allowed-methods)
|
|
(access-resource-using-method resource request method)
|
|
(error 'clash-error :code +HTTP-Code-Method-Not-Allowed+
|
|
:entity-initargs (list :allow allowed-methods)))))
|
|
|
|
(defclass static-resource (resource)
|
|
((entity :initarg :entity :accessor static-resource-entity)
|
|
(allowed-methods :allocation :class :initform '(:GET :HEAD)
|
|
:reader resource-allowed-methods)))
|
|
|
|
(defmethod access-resource-using-method
|
|
((resource static-resource) request (method (eql :GET)))
|
|
(create-response request +HTTP-Code-OK+
|
|
:entity
|
|
(static-resource-entity resource)))
|
|
|
|
(defmethod access-resource-using-method
|
|
((resource static-resource) request (method (eql :HEAD)))
|
|
(create-response request +HTTP-Code-OK+
|
|
:entity
|
|
(static-resource-entity resource)))
|
|
|
|
(defclass dynamic-resource (resource)
|
|
((allowed-methods :initarg :allowed-methods
|
|
:initform '(:GET :HEAD)
|
|
:reader resource-allowed-methods)
|
|
(generator :initarg :generator :reader dynamic-resource-generator)))
|
|
|
|
(defmethod access-resource-using-method
|
|
((resource dynamic-resource) request method)
|
|
(funcall (dynamic-resource-generator resource) resource request method))
|
|
|
|
(defclass dynamic-form-resource (dynamic-resource)
|
|
((processor :initarg :processor :reader dynamic-form-resource-processor))
|
|
(:default-initargs :allowed-methods '(:GET :HEAD :POST)))
|
|
|
|
(defmethod access-resource-using-method
|
|
((resource dynamic-form-resource) request (method (eql :POST)))
|
|
(funcall (dynamic-form-resource-processor resource) resource request method))
|
|
|
|
(defun parse-form-data (request)
|
|
(let* ((entity (request-entity request))
|
|
(data (entity-body entity)))
|
|
(parse-query-part data 0 (length data))))
|
|
|
|
(defmacro with-form-data (vars request &body body)
|
|
(loop with data-sym = (gensym)
|
|
for var in vars
|
|
collect
|
|
`(,var (cdr (assoc (symbol-name ',var) ,data-sym
|
|
:test #'string-equal)))
|
|
into bindings
|
|
finally
|
|
(return `(let ((,data-sym (parse-form-data ,request)))
|
|
(let ,bindings
|
|
,@body)))))
|
|
|
|
;;; Some further utility resources
|
|
|
|
;;; Redirection
|
|
|
|
(defclass redirector-resource (resource)
|
|
((code :initarg :code :initform +HTTP-Code-Moved-Temporarily+
|
|
:reader redirector-resource-code)
|
|
(destination :initarg :destination
|
|
:reader redirector-resource-destination)))
|
|
|
|
(defmethod access-resource ((resource redirector-resource) request)
|
|
(create-standard-response
|
|
request (redirector-resource-code resource)
|
|
:location (redirector-resource-destination resource)))
|