From dd99f55b19fef478e792c6c6a6b5d360d679c8fa Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Thu, 28 Nov 2024 11:52:05 -0800
Subject: Added thread-safe debug logging when debugging is on

---
 src/endpoint.lisp | 34 +++++++++++++++++++++++-----------
 src/protocol.lisp | 28 +++++++++++++++++++++++++++-
 2 files changed, 50 insertions(+), 12 deletions(-)

(limited to 'src')

diff --git a/src/endpoint.lisp b/src/endpoint.lisp
index 8189572..eeb536e 100644
--- a/src/endpoint.lisp
+++ b/src/endpoint.lisp
@@ -373,17 +373,24 @@ the ;."
    1. in path extractors
    2. in query parameters
    3. in the request body."
-  (let ((extracted-args
-          (process-extractors class))
-        (params-args
-          (extract-initargs args (http:get-parameters*)))
-        (body-args
-          (extract-initargs args (collect-body class)))) 
-    (apply #'make-instance class
+  (debug-print :instantiate-endpoint (class-name class) args)
+  (let* ((extracted-args
+           (process-extractors class))
+
+         (params-args
+           (extract-initargs args (http:get-parameters*)))
+
+         (body-args
+           (extract-initargs args (collect-body class)))
+
+         (collected-args
            (apply-slot-value-mappers
             class
             (reduce #'merge-plists
-                    (list extracted-args params-args body-args))))))
+                    (list extracted-args params-args body-args))))) 
+
+    (debug-print :initargs-collected collected-args)
+    (apply #'make-instance class collected-args)))
 
 (defun build-handler (class)
   "Create a hunchentoot dispatch function that instantiates and handles
@@ -397,9 +404,14 @@ the ;."
         (content-type
           (content-type class)))
     (lambda ()
-      (check-request-compliance class)
-      (setf (http:content-type*) content-type)
-      (handle (instantiate-endpoint class init-slots)))))
+      (let ((*debug-indent* 0)) 
+        (debug-print
+         (http:request-method*)
+         (http:request-uri*)
+         :dispatched-on (class-name class))
+        (check-request-compliance class)
+        (setf (http:content-type*) content-type)
+        (handle (instantiate-endpoint class init-slots))))))
 
 (defun create-class-dispatcher (class)
   "Creates a function that dispatches a handler function if a request
diff --git a/src/protocol.lisp b/src/protocol.lisp
index 31934f4..dfee2e6 100644
--- a/src/protocol.lisp
+++ b/src/protocol.lisp
@@ -5,8 +5,29 @@
 (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 *debugging* (not *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)
   ((raw-request
@@ -175,6 +196,11 @@ successfully.
 
 This method should return data to be sent back to the client and
 MUST be implemented for every endpoint class.")
+  (:method :around ((endpoint t))
+    (debug-print :handle endpoint)
+    (prog1 (call-next-method)
+      (debug-print)))
+
   (:method :before ((endpoint t))
     ;; The default before method checks that the endpoint is
     ;; authenticated, authorized, default, each of these is T.
-- 
cgit v1.2.3