From c52d6adca7fb81f5a476decc08d77cfcd6c4f229 Mon Sep 17 00:00:00 2001 From: Helmut Merz Date: Mon, 19 May 2025 15:43:07 +0200 Subject: [PATCH] improve / fix server response workflow using a foreground actor --- app/tst9/etc/config.lisp | 4 +++ core/actor.lisp | 10 ++++-- web/response.lisp | 69 ++++++++++++++++++++++------------------ web/server.lisp | 5 ++- 4 files changed, 52 insertions(+), 36 deletions(-) create mode 100644 app/tst9/etc/config.lisp diff --git a/app/tst9/etc/config.lisp b/app/tst9/etc/config.lisp new file mode 100644 index 0000000..7f891a7 --- /dev/null +++ b/app/tst9/etc/config.lisp @@ -0,0 +1,4 @@ +;;;; cl-scopes/app/tst9/etc/config + +(in-package :scopes/app/tst9) + diff --git a/core/actor.lisp b/core/actor.lisp index 2015bd8..cf6c9a8 100644 --- a/core/actor.lisp +++ b/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) diff --git a/web/response.lisp b/web/response.lisp index 3963cf4..0c6e524 100644 --- a/web/response.lisp +++ b/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"))) diff --git a/web/server.lisp b/web/server.lisp index fa13a1f..70e077c 100644 --- a/web/server.lisp +++ b/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