aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorcolin <colin@cicadas.surf>2024-05-05 08:16:12 -0700
committercolin <colin@cicadas.surf>2024-05-05 08:16:12 -0700
commit5ca3b134792735c5fe0cd55965d182efa5f90940 (patch)
treedb1bab1dfdfb05d8b0488d16c0bb6e98b564d42b /src
parent1e4235bb162a44bc9474c2fe4851724c41d827a6 (diff)
Add: endpoint registry and doc fn; body deserialized by req not ep
Diffstat (limited to 'src')
-rw-r--r--src/endpoint.lisp78
1 files changed, 65 insertions, 13 deletions
diff --git a/src/endpoint.lisp b/src/endpoint.lisp
index 81fdf74..103d86b 100644
--- a/src/endpoint.lisp
+++ b/src/endpoint.lisp
@@ -99,7 +99,7 @@ keyword arguments to make-instance for CLASS."
(content-type
:reader content-type
:initarg :content-type
- :initform "application/json"
+ :initform (error "CONTENT-TYPE required")
:type string
:documentation
"The content-type the handling of this request returns to the requesting client."))
@@ -107,9 +107,48 @@ keyword arguments to make-instance for CLASS."
(defmethod mop:validate-superclass ((sub endpoint) (sup standard-class)) t)
+;;; ENDPOINT CLASS REGISTRY
+
+(defvar *endpoint-registry* (make-hash-table :test #'eq)
+ "Instances of ENDPOINT register themselves to this table. Keys are
+symbol class names and values are (METHOD . ROUTE-PATTERN) pairs. The
+values are provided mostly in the interests of programmer
+friendlieness - you might want to quickly get a view of which
+endpoints are dispatching on which routes and methods.")
+
+(defun register-endpoint-class (class)
+ (let ((name (class-name class)))
+ (setf (gethash name *endpoint-registry*)
+ (cons (request-method class) (route class)))))
+
+(defun print-route-documentation (class &key (stream *standard-output*))
+ (let* ((class (if (symbolp class) (find-class class) class))
+ (extractors (route-extractors class))
+ (*standard-output* stream))
+ (flet ((extractor-arg (extractor)
+ (if (symbolp extractor) extractor (first extractor))))
+ (loop :repeat 80 :do (princ "_"))
+ (terpri) (terpri)
+ (format stream "~a ~a~%"
+ (request-method class)
+ (route class))
+ (let ((*print-case* :downcase))
+ (loop :for slotdef :in (mop:class-slots class)
+ :for initarg := (first (mop:slot-definition-initargs slotdef))
+ :for route-pos := (position initarg extractors :key #'extractor-arg)
+ :when initarg
+ :do (format stream "~10@a : ~10a ~a~%" ;;"~10@a : ~a ~a~%"
+ initarg
+ (or (mop:slot-definition-type slotdef) t)
+ (if route-pos
+ (format nil "(~:r in route)" (1+ route-pos))
+ ""))))
+ (a:when-let (doc (documentation class t))
+ (terpri)
+ (princ doc)))))
-;;; BODY PARSER REGISTRATION
+;;; BODY PARSER REGISTRATION
(defparameter +hunchentoot-pre-decoded-content-types+
'("multipart/form-data" "application/x-www-form-urlencoded"))
@@ -126,8 +165,12 @@ the request's POST-PARAMETERS slot."
(defvar *mimetype-parsers*
(make-hash-table :test #'equal))
-(defun lookup-body-parser (type)
- (gethash type *mimetype-parsers*))
+(defun lookup-body-parser (type &key errorp)
+ (multiple-value-bind (parser extant) (gethash type *mimetype-parsers*)
+ (when errorp
+ (unless extant
+ (error "Body parser not found for mimethype ~s~%Try registering a parser with (REGISTER-BODY-PARSER ~s <yourparser>)" type type)))
+ parser))
(defun register-body-parser (type function)
"TYPE should be a string naming a mimetype. FUNCTION should be a
@@ -298,6 +341,14 @@ Good for indicating that you've got a bonkers class option syntax"
(defun body-expected-p ()
(member (http:request-method*) +hunchentoot-methods-with-body+))
+(defun extract-mimetype (str)
+ "Expects a string that looks like text/plain;encoding=utf8 where
+everything after the ; is optional. Returns just the mimetype before
+the ;."
+ (a:if-let (pos (position #\; str))
+ (subseq str 0 pos)
+ str))
+
(defun collect-body (class)
"The body of the current request as an ALIST. If necessary, the body
will be parsed using CLASS's BODY-PARSER."
@@ -305,7 +356,8 @@ Good for indicating that you've got a bonkers class option syntax"
(or (and (pre-parsed-body-p)
(http:post-parameters*))
(do>
- parser :when= (lookup-body-parser (body-type class))
+ mimetype := (extract-mimetype (http:header-in* :content-type))
+ parser :when= (lookup-body-parser mimetype)
post-data :when= (http:raw-post-data
:external-format :utf8
:want-stream (want-body-stream class))
@@ -365,20 +417,20 @@ Good for indicating that you've got a bonkers class option syntax"
(setf (dispatch-function class) (create-class-dispatcher class))
(push (dispatch-function class) http:*dispatch-table*))
-
-(defmethod initialize-instance :after ((class endpoint) &key)
+(defun endpoint-class-post-processing (class)
(mop:ensure-finalized class)
(resolve-route-spec class)
(construct-route-builder class)
(check-endpoint-class class)
- (update-dispatch-function class))
+ (update-dispatch-function class)
+ (register-endpoint-class class))
+
+
+(defmethod initialize-instance :after ((class endpoint) &key)
+ (endpoint-class-post-processing 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))
+ (endpoint-class-post-processing class))
;;; TOOLS