diff options
Diffstat (limited to 'src/endpoint.lisp')
| -rw-r--r-- | src/endpoint.lisp | 78 |
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 |