diff options
| -rw-r--r-- | src/debugging.lisp | 44 | ||||
| -rw-r--r-- | src/endpoint.lisp | 6 | ||||
| -rw-r--r-- | src/protocol.lisp | 51 | ||||
| -rw-r--r-- | weekend.asd | 1 |
4 files changed, 63 insertions, 39 deletions
diff --git a/src/debugging.lisp b/src/debugging.lisp new file mode 100644 index 0000000..73d5de1 --- /dev/null +++ b/src/debugging.lisp @@ -0,0 +1,44 @@ +(in-package #:weekend) + +(defvar *debugging* nil + "If T, the debugger will be evoked.") + +(defvar *debug-indent* nil + "If an integer, debug print will print this many spaces before printing the debug message. It will then increment the count. + +The debug indent is bound when request handling starts.") + +(defvar *debug-log* nil + "An output stream bound when request handling begins and guaranteed to +be written to *ERROR-OUTPUT* when the handling finishes or raises an +error condition.") + +(defmacro with-debug-extent ((&key (stream '*error-output*)) &body body) + "When *DEBUGGING* is non NIL, calls to DEBUG-PRINT appearing anywhere +within the runtime extent of BODY will print to this handler thread's +debug log." + `(let ((*debug-log* (and *debugging* (make-debug-log))) + (*debug-indent* (and *debugging* 0))) + (unwind-protect (progn ,@body) + (write-debug-log :stream ,stream)))) + +(defun make-debug-log () + (make-array 512 + :element-type 'character + :fill-pointer 0 + :adjustable t)) + +(defun toggle-debugging () + (setf *debugging* (not *debugging*))) + +(defun debug-print (&rest objects) + (when (and *debugging* *debug-log*) + (with-output-to-string (*standard-output* *debug-log*) + (write-string "DEBUG: ") + (loop :repeat (or *debug-indent* 0) :do (write-char #\space)) + (format *standard-output* "~{~s ~}~%" objects) + (when *debug-indent* (incf *debug-indent* 2))))) + +(defun write-debug-log (&key (stream *error-output*)) + (when (and *debugging* *debug-log*) + (write-string *debug-log* stream))) diff --git a/src/endpoint.lisp b/src/endpoint.lisp index eeb536e..c8f1b22 100644 --- a/src/endpoint.lisp +++ b/src/endpoint.lisp @@ -373,7 +373,7 @@ the ;." 1. in path extractors 2. in query parameters 3. in the request body." - (debug-print :instantiate-endpoint (class-name class) args) + (debug-print :collecting-initargs) (let* ((extracted-args (process-extractors class)) @@ -389,7 +389,7 @@ the ;." (reduce #'merge-plists (list extracted-args params-args body-args))))) - (debug-print :initargs-collected collected-args) + (debug-print :using-initargs collected-args) (apply #'make-instance class collected-args))) (defun build-handler (class) @@ -404,7 +404,7 @@ the ;." (content-type (content-type class))) (lambda () - (let ((*debug-indent* 0)) + (with-debug-extent () (debug-print (http:request-method*) (http:request-uri*) diff --git a/src/protocol.lisp b/src/protocol.lisp index 3a4f3ec..ea6639a 100644 --- a/src/protocol.lisp +++ b/src/protocol.lisp @@ -2,34 +2,8 @@ ;;; CONDITIONS -(defvar *debugging* nil - "If T, the debugger will be evoked.") - -(defvar *debug-indent* nil - "If an integer, debug print will print this many spaces before printing the debug message. It will then increment the count. - -The debug indent is bound when request handling starts.") - -(defvar *debug-lock* nil - "Whens set, use this to ensure that writing to the debug stream doesn't -interleave writes across threads") - -(defun toggle-debugging () - (setf - *debug-lock* (bt:make-lock) - *debugging* (not *debugging*))) - -(declaim (inline debug-print)) -(defun debug-print (&rest objects) - (when *debugging* - (bt:with-lock-held (*debug-lock*) - (write-string "DEBUG: " *error-output*) - (loop :repeat (or *debug-indent* 0) - :do (write-char #\space *error-output*)) - (format *error-output* "~{~s ~}~%" objects) - (when *debug-indent* (incf *debug-indent* 2))))) - -(define-condition protocol-error (error) + +(define-condition protocol-error () ((raw-request :reader raw-request :initform nil @@ -64,7 +38,7 @@ indicating that the user's identity is required but cannot be determined.")) (:documentation "Signalled when an endpoint's AUTHORIZE method returns NIL, indiating that the request has insufficient permissions to evoke the endpoint handler. ")) -(define-condition bad-body-error (protocol-error) +(define-condition bad-body-error (error protocol-error) ((wrapped :reader wrapped :initarg :error @@ -73,7 +47,7 @@ that the request has insufficient permissions to evoke the endpoint handler. ")) (:default-initargs :status-code 400) (:documentation "Signalled when the body of a request cannot be deserialized, for any reason..")) -(define-condition slot-required (protocol-error) +(define-condition slot-required (error protocol-error) ((mising-slot :reader missing-slot :initform nil @@ -94,7 +68,7 @@ that the request has insufficient permissions to evoke the endpoint handler. ")) (:documentation "The content and mimetype to returned to the client having encountered an error.") - (:method ((err error)) (values nil nil))) + (:method ((err t)) (values nil nil))) (defun abort-on-error (err) "Assign a return code based on the type of error encountered and @@ -112,10 +86,13 @@ that the request has insufficient permissions to evoke the endpoint handler. ")) (error (err) (if *debugging* (invoke-debugger err) - (abort-on-error err))))) + (abort-on-error err))) + (protocol-error (err) + (abort-on-error err)))) (defun protocol-error (error-class ep &rest kwargs) - (apply #'error + (debug-print :protocol-error error-class kwargs) + (apply #'signal error-class :raw-request (and (boundp 'http:*request*) http:*request*) :class ep @@ -205,8 +182,9 @@ MUST be implemented for every endpoint class.") (:method :around ((endpoint t)) (debug-print :handling endpoint) (prog1 (call-next-method) - (debug-print :content-type (http:content-type*) - :content-length (http:content-length*)) + (debug-print + :replying-with (http:return-code*) + :content-type (http:content-type*)) (debug-print))) (:method :before ((endpoint t)) @@ -215,7 +193,8 @@ MUST be implemented for every endpoint class.") (unless (authenticate endpoint) (protocol-error 'cannot-authenticate endpoint)) (unless (authorize endpoint) - (protocol-error 'not-authorized endpoint)))) + (protocol-error 'not-authorized endpoint)) + (debug-print :proceeding-to-handler))) ;;; HANDLER TOOLS diff --git a/weekend.asd b/weekend.asd index ff0ee8e..0e75196 100644 --- a/weekend.asd +++ b/weekend.asd @@ -9,6 +9,7 @@ :pathname "src/" :serial t :components ((:file "package") + (:file "debugging") (:file "protocol") (:file "endpoint") (:file "defendpoint"))) |