From dc33589b34af73c14ff25e42488f31e0b09ba405 Mon Sep 17 00:00:00 2001
From: Colin Okay <okay@toyful.space>
Date: Wed, 16 Feb 2022 13:28:28 -0600
Subject: cacheing calls to request-body per request in backend

---
 lazybones-hunchentoot.lisp | 101 ++++++++++++++++++++++++---------------------
 1 file changed, 55 insertions(+), 46 deletions(-)

diff --git a/lazybones-hunchentoot.lisp b/lazybones-hunchentoot.lisp
index 09152ce..be3e009 100644
--- a/lazybones-hunchentoot.lisp
+++ b/lazybones-hunchentoot.lisp
@@ -10,7 +10,7 @@
 
 ;;; Hunchentoot Acceptor Subclass
 
-(defvar %server nil
+(defvar %server% nil
   "unexported defvar holding the lazybones-acceptor instance.")
 
 (defclass lazybones-acceptor (h:acceptor)
@@ -29,26 +29,33 @@
   (:default-initargs
    :address "127.0.0.1"))
 
-(defmethod h:acceptor-dispatch-request ((%server lazybones-acceptor) request)
-  (handler-case  
-      (loop for app in (acceptor-apps %server)
-            for (endpoint . args) = (lzb::find-endpoint app request)
-            when endpoint
-              return (lzb::run-endpoint endpoint args request h:*reply* app)
-            ;; if no endpoint was found, call next method. 
-            finally (let ((lzb:*request* request)
-                          (lzb:*response* h:*reply*))
-                      (return (lzb:http-err 404))))
-    (lzb::http-error (http-error)
-      (let ((lzb:*request* request)
-            (lzb:*response* h:*reply*))
-        (with-slots (lzb::code lzb::content) http-error
-          (http-respond lzb::content lzb::code))))
-    (error (e)
-      (declare (ignorable e))
-      (let ((lzb:*request* request)
-            (lzb:*response* h:*reply*))
-        (http-respond 500)))))
+(defvar %request-body-cache% nil
+  "Internal use. Dynamically bound per request. Caches the request
+  body after the first call to REQUEST-BODY so that subsequent calls
+  return the same thing, even if they've already been read off the
+  stream.")
+
+(defmethod h:acceptor-dispatch-request ((%server% lazybones-acceptor) request)
+  (let ((%request-body-cache% nil)) 
+    (handler-case  
+        (loop for app in (acceptor-apps %server%)
+              for (endpoint . args) = (lzb::find-endpoint app request)
+              when endpoint
+                return (lzb::run-endpoint endpoint args request h:*reply* app)
+              ;; if no endpoint was found, call next method. 
+              finally (let ((lzb:*request* request)
+                            (lzb:*response* h:*reply*))
+                        (return (lzb:http-err 404))))
+      (lzb::http-error (http-error)
+        (let ((lzb:*request* request)
+              (lzb:*response* h:*reply*))
+          (with-slots (lzb::code lzb::content) http-error
+            (http-respond lzb::content lzb::code))))
+      (error (e)
+        (declare (ignorable e))
+        (let ((lzb:*request* request)
+              (lzb:*response* h:*reply*))
+          (http-respond nil 500))))))
 
 ;;; SERVER FUNCTIONS
 
@@ -166,30 +173,32 @@ HEADER-NAME can be a keyword or a string."
 (defun request-body (&key (request lzb:*request*) (want-stream-p nil))
   "Returns the decoded request body. The value returned depends upon
 the value of the Content-Type request header."
-  (when (member (request-method request) +hunchentoot-methods-with-body+)
-    (let ((pre-decoded-body-p
-            (pre-decoded-body-p request))
-          (content-type
-            (request-header :content-type request))) 
-      (cond
-        ;; try to get a stream on request
-        (want-stream-p                
-         ;; can't do it if the body is already decoded - return nil so
-         ;; that request-body can be called again
-         (unless pre-decoded-body-p 
-           (h:raw-post-data :request request :want-stream t)))
-
-        (pre-decoded-body-p
-         (format-as-lazybones-document
-          (h:post-parameters request)))
-
-        ((string-equal "application/json" content-type)
-         (jonathan:parse
-          (h:raw-post-data :request request :external-format :utf8 ))) ; TODO don't hardcode the format
-
-        (t
-         ;; default case is to return a bytevector
-         (h:raw-post-data :request request :force-binary t))))))
+  (if %request-body-cache% %request-body-cache% 
+      (setf %request-body-cache%
+            (when (member (request-method request) +hunchentoot-methods-with-body+)
+              (let ((pre-decoded-body-p
+                      (pre-decoded-body-p request))
+                    (content-type
+                      (request-header :content-type request))) 
+                (cond
+                  ;; try to get a stream on request
+                  (want-stream-p                
+                   ;; can't do it if the body is already decoded - return nil so
+                   ;; that request-body can be called again
+                   (unless pre-decoded-body-p 
+                     (h:raw-post-data :request request :want-stream t)))
+
+                  (pre-decoded-body-p
+                   (format-as-lazybones-document
+                    (h:post-parameters request)))
+
+                  ((string-equal "application/json" content-type)
+                   (jonathan:parse
+                    (h:raw-post-data :request request :external-format :utf8 ))) ;TODO: don't hardcode utf8
+
+                  (t
+                   ;; default case is to return a bytevector
+                   (h:raw-post-data :request request :force-binary t))))))))
 
 (defun format-as-lazybones-document (post-parameters)
   "internal function. Formats all the post parmaeters (see docstring
@@ -236,7 +245,7 @@ return the content."
   ;; code, and set content and content-type appropriately
   (a:when-let (data
                (and (null content)
-                    (canned-response %server code)))
+                    (canned-response %server% code)))
     (destructuring-bind (source content-type) data
       (setf (response-header :content-type) content-type
             content (if (or (functionp source) (symbolp source))
-- 
cgit v1.2.3