aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/endpoint.lisp277
-rw-r--r--src/package.lisp14
-rw-r--r--src/protocol.lisp30
-rw-r--r--src/server.lisp0
4 files changed, 304 insertions, 17 deletions
diff --git a/src/endpoint.lisp b/src/endpoint.lisp
index 9ec1937..c0b89da 100644
--- a/src/endpoint.lisp
+++ b/src/endpoint.lisp
@@ -27,7 +27,13 @@
"Return the list of all INITARG symbols that can be supplied as
keyword arguments to make-instance for CLASS."
(reduce #'append (mop:class-slots class)
- :key #'mop:slot-definition-initargs))
+ :key #'mop:slot-definition-initargs
+ :initial-value nil))
+
+(defun class-slot-names (class)
+ (mapcar
+ #'closer-mop:slot-definition-name
+ (closer-mop:class-slots (find-class class))))
;;; ENDPOINT METACLASS
@@ -60,6 +66,12 @@ keyword arguments to make-instance for CLASS."
consisting in an INITARG and a function to parse a regex group
match. There should be the same number of extractors as there
are regex groups in ROUTE.")
+ (route-builder
+ :accessor route-builder
+ :type function
+ :documentation
+ "A function that generates a route to this endpoint. It is constructed
+ from the route and stored here.")
(method
:reader request-method
:initarg :method
@@ -118,6 +130,13 @@ the request's POST-PARAMETERS slot."
(gethash type *mimetype-parsers*))
(defun register-body-parser (type function)
+ "TYPE should be a string naming a mimetype. FUNCTION should be a
+designator for a function that accepts a string and returns an
+association list keyed by strings."
+ (when (pre-parsed-body-p type)
+ (warn "You are registering a body parser for ~s but it will be ignored
+ because Hunchentoot pre-parses request bodies of that
+ type." type))
(setf (gethash type *mimetype-parsers*) function))
(define-condition unregistered-body-type (warning)
@@ -147,18 +166,47 @@ Check your spelling or call
"If CLASS has a route spec, then it is transfomred into a route
matching regex."
(cond
- ((and (slot-boundp class 'route) (not (slot-boundp class 'route-parts)))
- ;; we don't want to set anything, but it can't hurt to check the value
- (unless (stringp (route class))
- (error "Route should be a string representing a valid regular expression.")))
- ((and (not (slot-boundp class 'route)) (slot-boundp class 'route-parts))
+ ((slot-boundp class 'route-parts)
(setf (slot-value class 'route)
(route-matching-regex (route-parts class))))
(t
(error
- "Exactly one of :RAW-ROUTE or :ROUTE-PARTS must be supplied to the defintion of class ~a"
+ ":ROUTE-PARTS must be supplied to the defintion of class ~a"
(class-name class)))))
+(defun construct-route-builder (class)
+ (assert (slot-boundp class 'route))
+ (let ((build-parts nil))
+ (loop
+ :with extractors := (copy-seq (route-extractors class))
+ :for part :in (ppcre:parse-string (route class))
+ :do (cond
+ ((stringp part)
+ (push part build-parts))
+ ((symbolp part) nil)
+ ((and (listp part)
+ (eq :register (first part))
+ extractors)
+ (let ((ex (pop extractors)))
+ (push (if (listp ex) (first ex) ex)
+ build-parts)))
+ (t
+ (error "Cannot build route-builder.
+
+Non-literal, non-line-boundary regex patterns must be surrounded by
+parens. There must be exactly as many patterns as there are
+extractors."))))
+ (setf build-parts (nreverse build-parts))
+ (setf (route-builder class)
+ (lambda (kwargs)
+ (apply #'concatenate 'string
+ (loop :for part :in build-parts
+ :when (keywordp part)
+ :do (assert (getf kwargs part) () "path needs ~s" part)
+ :and :collect (getf kwargs part)
+ :else
+ :collect part))))))
+
(defun check-endpoint-class (class)
"Signals an error if any slot values are malformed.
@@ -317,14 +365,225 @@ Good for indicating that you've got a bonkers class option syntax"
(defmethod initialize-instance :after ((class endpoint) &key)
(mop:ensure-finalized class)
(resolve-route-spec class)
+ (construct-route-builder class)
(check-endpoint-class class)
(update-dispatch-function class))
(defmethod reinitialize-instance :after ((class endpoint) &key)
(mop:ensure-finalized class)
(resolve-route-spec class)
+ (construct-route-builder class)
(check-endpoint-class class)
(update-dispatch-function class))
-
-
+;;; TOOLS
+
+(defun route-to (class &rest kwargs)
+ (funcall (route-builder (if (symbolp class) (find-class class) class)) kwargs))
+
+
+;;; DEFENDPOINT
+
+(defun path-part-p (part)
+ "Returns T if PART is a a valid route path part.
+
+PART is either
+ STRING
+ (KEYWORD STRING)
+ (KEYWORD STRING FUNCTION-NAME)"
+ (or (stringp part)
+ (and (listp part)
+ (or (and (= 2 (length part))
+ (do>
+ (key str) :match= part
+ :when (keywordp key)
+ :when (stringp str)))
+ (and (= 3 (length part))
+ (do>
+ (key str parser) :match= part
+ :when (keywordp key)
+ :when (string str)
+ :when (symbolp parser)
+ (assert (fboundp parser) (parser)
+ "No parser bound to ~s for route initarg ~s"
+ parser key)))))))
+
+(defun parameter-spec-p (spec)
+ "Returns T if SPEC is a valid parameter spec for a DEFENDPOINT form.
+
+(NAME TYPE &OPTIONAL DOC)"
+ (and (listp spec)
+ (symbolp (first spec))
+ (symbolp (second spec))
+ (or (not (third spec))
+ (stringp (third spec)))))
+
+(defun property-spec-p (spec)
+ "Returns T if SPEC is a valid property spec for a DEFENDPOINT form.
+
+(NAME TYPE &KEY DEFAULT DOC)"
+ (and (listp spec)
+ (symbolp (first spec))
+ (symbolp (second spec))))
+
+(defun params-to-slotdefs (specs)
+ (loop :for (name type . doc) :in specs
+ :collect `(,name
+ :accessor ,name
+ :initarg ,(a:make-keyword name)
+ :type ,type
+ :documentation ,(or (first doc) ""))))
+
+(defun props-to-slotdefs (specs)
+ (loop :for (name type . kwargs) :in specs
+ :collect `(,name
+ :accessor ,name
+ :initform ,(getf kwargs :default)
+ :type (or null ,type)
+ :documentation ,(or (getf kwargs :doc "")
+ (getf kwargs :documentation "")))))
+
+(defun expand-endpoint-class
+ (name method pathspec handle
+ &key
+ supers
+ parameters
+ properties
+ metaclass
+ var
+ doc
+ authenticate
+ authorize)
+ (setf var (or var (gensym "REQ-")))
+ (setf metaclass (or metaclass 'endpoint))
+ (let* ((slot-defs
+ (nconc (params-to-slotdefs parameters)
+ (props-to-slotdefs properties)))
+ (all-slots
+ (nconc (mapcar #'first slot-defs)
+ (reduce #'union supers :key #'class-slot-names :initial-value nil)))
+ (route-parts
+ (loop :for part :in pathspec
+ :when (stringp part)
+ :collect part
+ :else
+ :collect (second part)))
+ (extractors
+ (loop :for part :in pathspec
+ :when (listp part)
+ :collect (if (third part)
+ (list (first part) (third part))
+ (first part))))
+ (class-options
+ (nconc
+ (list (list :metaclass metaclass))
+ (list (cons :method method))
+ (list (list* :route-parts route-parts))
+ (when extractors
+ (list (list* :extractors extractors)))
+ (when doc
+ (list (list :documentation doc))))))
+ `(progn
+ (defclass ,name ,supers
+ ,slot-defs
+ ,@class-options)
+
+ (defmethod handle ((,var ,name))
+ (with-slots ,all-slots ,var
+ ,handle))
+
+ ,@(when authenticate
+ (list
+ `(defmethod authenticate ((,var ,name))
+ (with-slots ,all-slots ,var
+ ,authenticate))))
+
+ ,@(when authorize
+ (list
+ `(defmethod authorize ((,var ,name))
+ (with-slots ,all-slots ,var
+ ,authorize)))))))
+
+(argot:deflanguage defendpoint ()
+ (<class>
+ :match (:seq (:@ name (:item))
+ (:@ supers (:? <supers>))
+ (:@ method <method>)
+ (:@ pathspec <pathspec>)
+ (:@ params (:? <parameters>))
+ (:@ props (:? <properties>))
+ (:@ metaclass (:? <metaclass>))
+ (:@ doc (:? <doc>))
+ (:@ var (:? <var>))
+ (:@ authenticate (:? <authenticate>))
+ (:@ authorize (:? <authorize>))
+ (:@ handle <handle>)
+ (:eof))
+ :then (expand-endpoint-class
+ name
+ method
+ pathspec
+ handle
+ :supers supers
+ :parameters params
+ :properties props
+ :metaclass metaclass
+ :var var
+ :authenticate authenticate
+ :authorize authorize))
+ (<supers>
+ :match (:seq (:= :extends) (:+ <classname>))
+ :then second)
+ (<classname>
+ :match (:item)
+ :if find-class)
+ (<method>
+ :match (:or= :get :post :put :patch :head :delete))
+ (<pathspec>
+ :match (:seq (:or= :to :from :at) (:+ <pathpart>))
+ :then second)
+ (<pathpart>
+ :match (:item)
+ :if path-part-p
+ :note "REGEX or (KWD REGEX &optional PARSER)")
+ (<parameters>
+ :match (:seq (:= :parameters) (:+ <param>))
+ :then second)
+ (<param>
+ :match (:item)
+ :if parameter-spec-p
+ :note "(NAME TYPE &optional DOCSTRING)")
+ (<properties>
+ :match (:seq (:= :properties) (:+ <prop>))
+ :then second)
+ (<prop>
+ :match (:item)
+ :if property-spec-p
+ :note "(NAME TYPE &key DEFAULT DOCSTRING)")
+ (<doc>
+ :match (:seq (:or= :doc :documentation) (:@ doc (:item)))
+ :if (stringp doc)
+ :then second
+ :note "STRING")
+ (<metaclass>
+ :match (:seq (:= :custom) <classname>)
+ :if (mop:subclassp (second <metaclass>) 'endpoint)
+ :then second
+ :note "SYMBOL naming a subclass of ENDPOINT")
+ (<var>
+ :match (:seq (:= :var) (:item))
+ :if (symbolp (second <var>))
+ :then second
+ :note "SYMBOL bound to the instance during the handler protocol.")
+ (<authenticate>
+ :match (:seq (:= :authenticate) (:item))
+ :then second
+ :note "Body form of authenticate method.")
+ (<authorize>
+ :match (:seq (:= :authorize) (:item))
+ :then second
+ :note "Body form of authorize method.")
+ (<handle>
+ :match (:seq (:= :handle) (:item))
+ :then second
+ :note "Body form of handle method."))
diff --git a/src/package.lisp b/src/package.lisp
index c60d03b..a9ab69f 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -5,4 +5,16 @@
(:local-nicknames
(#:http #:hunchentoot)
(#:a #:alexandria-2)
- (#:mop #:closer-mop)))
+ (#:mop #:closer-mop))
+ (:export
+ ;; HANDLER PROTOCOL
+ #:authenticate
+ #:authorize
+ #:handle
+ #:not-found
+ #:slot-required
+
+ ;; METACLASS
+ #:endpoint
+ #:register-body-parser))
+
diff --git a/src/protocol.lisp b/src/protocol.lisp
index 19a4791..d25aa22 100644
--- a/src/protocol.lisp
+++ b/src/protocol.lisp
@@ -52,7 +52,7 @@ that the request has insufficient permissions to evoke the endpoint handler. "))
(:documentation "Signalled whenever a required slot is missing from a endpoint
instance object."))
-(define-condition not-found (protocol-error)
+(define-condition not-found (protocol-error) ()
(:default-initargs :status-code 404))
(defgeneric protocol-error-result (err)
@@ -88,15 +88,18 @@ that the request has insufficient permissions to evoke the endpoint handler. "))
(invoke-debugger err)
(http:abort-request-handler)))))
-(defun protocol-error (error-class req &rest kwargs)
+(defun protocol-error (error-class ep &rest kwargs)
(apply #'error
error-class
:raw-request http:*request*
- :class (class-of req)
+ :class (class-of ep)
kwargs))
-(defun not-found (req)
- (protocol-error 'not-found req))
+
+(defun slot-required (ep slot)
+ "Signals a SLOT-REQUIRED condition"
+ (protocol-error 'slot-required ep :missing-slot slot))
+
;;; HANDLER PROTOCOL
@@ -105,13 +108,13 @@ that the request has insufficient permissions to evoke the endpoint handler. "))
this. Called before handling, should be used to supply
user-identifying data to the endpoint instance that might be needed by
the handle function.")
- (:method ((req t)) t))
+ (:method ((ep t)) t))
(defgeneric authorize (endpoint)
(:documentation "Returns a boolean. Any endpoint requiring special ownership
permissions should implement this. Called before handling and after
authenticate.")
- (:method ((req t)) t))
+ (:method ((ep t)) t))
(defgeneric handle (endpoint)
(:documentation "The beef of the endpoint handling protocol.
@@ -139,6 +142,19 @@ MUST be implemented for every endpoint class.")
(unless (authorize endpoint)
(protocol-error 'not-authorized endpoint))))
+;;; HANDLER TOOLS
+(defun not-found (ep)
+ "Signals a NOT-FOUND condition. Usually called within HANDLE or
+AUTHORIZE while handling endpoint-class instance EP."
+ (protocol-error 'not-found ep))
+(defun redirect (url)
+ "Redirect to URL."
+ (http:redirect url :code http:+http-see-other+))
+(defun redirect-to (class &rest kwargs)
+ "Redirect to another endpoint. CLASS can be either a symbol or a
+ class. KWARGS is a PLIST of keyword arguments supplied to the
+ CLASS' route builder function."
+ (redirect (apply #'route-to class kwargs)))
diff --git a/src/server.lisp b/src/server.lisp
deleted file mode 100644
index e69de29..0000000
--- a/src/server.lisp
+++ /dev/null