More complete debugging of request lifecycleHEADmain

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")))