improve / fix server response workflow using a foreground actor

app/tst9/etc/config.lisp

@@ -0,0 +1,4 @@
+;;;; cl-scopes/app/tst9/etc/config
+
+(in-package :scopes/app/tst9)
+

core/actor.lisp

@@ -28,15 +28,21 @@
 (defclass bg-actor (actor)
   ((task :accessor task :initform nil)))
 
+(defmethod initialize-instance :after ((ac bg-actor) &key &allow-other-keys)
+  (setf (task ac) (make-task ac)))
+
 (defclass fg-actor (bg-actor) ())
 
+(defmethod initialize-instance :after ((ac fg-actor) &key &allow-other-keys)
+  (setf (task ac) (make-task ac 'async:fg-task)))
+
 (defgeneric start (ac)
   (:method ((ac actor)))
   (:method ((ac bg-actor))
-    (setf (task ac) (make-task ac))
+    ;(setf (task ac) (make-task ac))
     (async:start (task ac)))
   (:method ((ac fg-actor))
-    (setf (task ac) (make-task ac 'async:fg-task))
+    ;(setf (task ac) (make-task ac 'async:fg-task))
     (async:start (task ac))))
 
 (defgeneric stop (ac)

web/response.lisp

@@ -2,13 +2,14 @@
 
 (defpackage :scopes/web/response
   (:use :common-lisp)
-  (:local-nicknames (:cookie :scopes/web/cookie)
+  (:local-nicknames (:actor :scopes/core/actor)
+                    (:cookie :scopes/web/cookie)
                     (:core :scopes/core)
                     (:dom :scopes/web/dom)
                     (:message :scopes/core/message)
                     (:shape :scopes/shape)
                     (:util :scopes/util))
-  (:export #:interaction #:setup #:html-response
+  (:export #:setup #:html-response
            #:render #:render-content #:render-not-found))
 
 (in-package :scopes/web/response)
@@ -16,27 +17,23 @@
 ;;;; server interaction - receive response message from action processing chain
 ;;; predefined action handlers / default actions
 
-(defun render-msg (ia msg)
-  (push msg (messages ia)))
+(defun render-msg (resp msg)
+  (push msg (messages resp))
+  (actor:stop resp)
+  ;(finish resp)
+  )
 
-(defun set-cookie (ia msg)
-  (util:plist-add (headers (response ia)) 
-                  :set-cookie (render-cookie (shape:data msg))))
+(defun set-cookie (resp msg)
+  (util:plist-add (headers resp) 
+                  :set-cookie (render-cookie (shape:data msg)))
+  (actor:stop resp)
+  ;(finish resp)
+  )
 
 (defvar *interaction-default-actions* 
   (core:define-actions '((:response :set-cookie) set-cookie) 
                        '(nil render-msg)))
 
-;;; interaction class and methods
-
-(defclass interaction (core:base-context)
-  ((core:actions :initform *interaction-default-actions*)
-   (response :reader response :initarg :response)
-   (messages :accessor messages :initform nil)))
-
-(defmethod print-object ((ia interaction) s)
-  (shape:print-fields ia s 'messages))
-
 (defun render-cookie (cdata)
   (let ((cookie (apply #'cookie:create-from-keys cdata)))
     (cookie:make-header cookie)))
@@ -45,11 +42,19 @@
 
 (defvar *html-response-class* nil)
 
-(defclass response ()
+;(defclass response (core:base-context)
+(defclass response (core:base-context actor:fg-actor) ; actor:bg-actor
   ((context :reader context :initarg :context)
+   (core:actions :initform *interaction-default-actions*)
    (env :reader env :initarg :env)
+   (messages :accessor messages :initform nil)
    (headers :accessor headers :initform nil)
-   (ctype :reader ctype :allocation :class)))
+   (ctype :reader ctype :allocation :class)
+   (responder :accessor responder)
+   (writer :accessor writer)))
+
+(defmethod print-object ((resp response) s)
+  (shape:print-fields resp s 'messages))
 
 (defgeneric render-content (resp msg))
 
@@ -72,7 +77,7 @@
 (defun setup (ctx env &key html-responder)
   (let* ((headers (getf env :headers))
          (resp-class (select-response-class (gethash "accept" headers) html-responder)))
-    (make-instance resp-class :context ctx :env env)))
+    (actor:make-actor #'core:handle-message resp-class :context ctx :env env)))
 
 (defun select-response-class (accept html-responder)
   (let ((accept (string-downcase accept)))
@@ -88,17 +93,19 @@
 (defun make-headers (resp)
   (cons :content-type (cons (ctype resp) (headers resp))))
 
-(defun render (resp iact)
-  ; pre-process special message heads, e.g. (:system :error ...)
-  ;   => set status code, provide additional data elements
-  ;      set additional headers (<- will be done by interaction)
-  (let ((headers (make-headers resp))
-        (rcode 200))
-    #'(lambda (responder)
-        (let ((writer (funcall responder (list rcode headers))))
-          (dolist (msg (messages iact))
-            (funcall writer (render-content resp msg)))
-          (funcall writer nil :close t)))))
+(defun finish (resp)
+  (let* ((headers (make-headers resp))
+         (rcode 200)
+         (writer (funcall (responder resp) (list rcode headers))) )
+    (dolist (msg (messages resp))
+      (funcall writer (render-content resp msg)))
+    (funcall writer nil :close t)))
+
+(defun render (resp)
+  #'(lambda (responder)
+      (setf (responder resp) responder)
+      (actor:start resp)
+      (finish resp)))
 
 (defun render-not-found(resp)
   (list 404 '(:content-type "text/plain") '("Not found")))

web/server.lisp

@@ -90,13 +90,12 @@
 
 (defun message-handler (ctx env &key html-responder)
   (let* ((resp (response:setup ctx env :html-responder html-responder))
-         (iact (actor:create #'core:handle-message 'response:interaction :response resp))
          (msg (message:create 
-                (head env) :data (plist (post-data env)) :customer iact)))
+                (head env) :data (plist (post-data env)) :customer resp)))
     (util:lgd msg)
     ; (check-auth ctx msg env) => (response:render-unauthorized resp)
     (if (core:handle-message ctx msg)
-      (response:render resp iact)
+      (response:render resp)
       (response:render-not-found resp))))
 
 ;;;; predefined action handlers