refactor: stand-alone close-env-reblocks macro

src/websocket.lisp

@@ -521,52 +521,114 @@ for each widget, because of symbols autogenerated by Parenscript.")
 (defmethod reblocks/routes:serve ((route websocket-route) env)
   (process-websocket env))
 
+(defmacro close-env-bare (vars &body body)
+  "Capture dynamic variables in a closure.
+
+(defvar *x* 1)
+(defvar *y* 2)
+
+(let ((*x* 10)
+      (*y* 20))
+  (defparameter x (close-env-bare (*x* *y*)
+                    (list *x* *y*))))
+
+(funcall x)
+=> (10 20)
+"
+  (let ((syms (mapcar (lambda (sym)
+                        (list (gensym (symbol-name sym)) sym))
+                      vars)))
+    ;; Capture the env
+    `(let (,@syms)
+       ;; Callback function
+       (lambda ()
+         ;; Which first restores the env
+         (let (,@ (mapcar #'reverse syms))
+           ,@body)))))
+
+
+(defmacro close-env (vars &body body)
+  "Capture dynamic variables in a closure, optionally skippable.
+
+Like ‘close-env-bare’ but supports skipping individual variables.
+
+(defvar *x* 1)
+(defvar *y* 2)
+(defvar *z* 3)
+
+(defpackage #:foobar)
+
+(let ((*x* 11)
+      (*y* 12)
+      (*z* 13))
+  (defparameter x (close-env (*x*
+                              (*y* (find-package \"FOOBAR\"))
+                              ((find-symbol \"FOO\" \"FAKE\") NIL))
+                    (list *x* *y* *z*))))
+
+(funcall x)
+=> (11 12 3)
+
+Note the third binding isn’t evaluated because its conditional is NIL--if it
+were, it would throw an error because the package FAKE does not exist.
+"
+  `(close-env-bare ,(mapcan (lambda (x)
+                              (if (symbolp x)
+                                  (list x)
+                                  (destructuring-bind (sym cond) x
+                                    (when (eval cond)
+                                      (list (if (symbolp sym)
+                                                sym
+                                                (eval sym)))))))
+                            vars)
+     ,@body))
+
+
+(defmacro stripf-ajax-header (request)
+  "Strip the AJAX header off this request."
+  `(when (reblocks/request:get-header "X-Requested-With"
+                                      :request ,request)
+     (setf ,request
+           (reblocks/request:remove-header "X-Requested-With"
+                                           :request ,request))))
+
+
+(defmacro close-reblocks-env (&body body)
+  "Create a closure over known reblocks dynamic variables for async calling.
+
+Ensures that reblocks/session::*session* and reblocks/request:*request* will be
+bound during it's execution.
+
+Also, it sets reblocks.websocket:*backround* to true, to make `update' method
+distinguish between usual request processing and background activity.
+"
+  `(progn
+     ;; Here we need to drop this header if it exists, to make ajax-request-p
+     ;; return false for subsequent calls in the thread. This must happen in the
+     ;; /calling/ thread, not the callback, although it’s unclear to me why.
+     (stripf-ajax-header reblocks/request::*request*)
+     (close-env (reblocks/session::*session*
+                 reblocks/request::*request*
+                 reblocks/page::*current-page*
+                 reblocks/routes::*routes*
+                 ((alexandria:ensure-symbol '*evloop* :woo) (find-package :woo)))
+       (let ((*background* t))
+         ,@body))))
+
 
 (defmacro in-thread ((thread-name) &body body)
   "Starts given piece of code in named thread, ensiring that reblocks/session::*session* and
 reblocks/request:*request* will be bound during it's execution.
 
 Also, it set reblocks.websocket:*backround* to true, to make `update' method distinguish
-between usual request processing and background activity."
-
-  (flet ((let-bindings (&rest args)
-           "Returns a list or given arguments while removing nils.
-            Suitable to form let's bind in macroses."
-           (remove-if #'null args)))
-
-    (let* ((woo-package (find-package :woo))
-           (ev-loop-symbol (when woo-package
-                             (alexandria:ensure-symbol '*evloop*
-                                                       :woo))))
-      `(let* ,(let-bindings
-               '(session reblocks/session::*session*)
-               '(request reblocks/request::*request*)
-               '(page reblocks/page::*current-page*)
-               '(routes reblocks/routes::*routes*)
-               (when woo-package
-                 (list 'evloop ev-loop-symbol)))
-         ;; Here we need to drop this header if it exists,
-         ;; to make ajax-request-p return false for subsequent calls
-         ;; in the thread.
-         (when (reblocks/request:get-header "X-Requested-With"
-                                            :request request)
-           (setf request
-                 (reblocks/request:remove-header "X-Requested-With"
-                                                 :request request)))
-
-         (log:debug "Creating a thread to update state via websocket")
-         (bt:make-thread (lambda ()
-                           (let ,(let-bindings
-                                  '(reblocks/session::*session* session)
-                                  '(reblocks/request::*request* request)
-                                  '(reblocks/page::*current-page* page)
-                                  '(reblocks/routes::*routes* routes)
-                                  ;; Hack
-                                  (when woo-package
-                                    (list ev-loop-symbol 'evloop))
-                                  '(*background* t))
-                             ,@body))
-                         :name ,thread-name)))))
+between usual request processing and background activity.
+"
+  `(progn
+     (log:debug "Creating a thread to update state via websocket")
+     (bt:make-thread
+      (close-reblocks-env
+        ,@body)
+      :name ,thread-name)))
 
 
 (defmacro in-thread-loop ((thread-name) &body body)