Add: endpoint registry and doc fn; body deserialized by req not ep

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