cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

work in progess: use new actor implementation in web

Browse source
This commit is contained in:
Helmut Merz 2025-06-02 23:12:57 +02:00
parent 02b0549233
commit 059c99e8de
4 changed files with 18 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
core/core.lisp
View file

@ -83,8 +83,7 @@
(defun setup-services (&optional (cfg config:*root*)) (defun setup-services (&optional (cfg config:*root*))
(async:init) (async:init)
(let* ((ctx (make-instance 'context :config cfg)) (let* ((ctx (make-instance 'context :config cfg)))
(bhv (lambda (msg) (funcall #'handle-message ctx msg))))
(setf (mailbox ctx) (lpq:make-queue)) (setf (mailbox ctx) (lpq:make-queue))
(setf *root* ctx)) (setf *root* ctx))
(dolist (c (reverse (config:children cfg))) (dolist (c (reverse (config:children cfg)))
@ -94,7 +93,9 @@
(unwind-protect (unwind-protect
(progn (progn
(setup-services cfg) (setup-services cfg)
(actor:start (mailbox *root*) :foreground t)) (actor:start (mailbox *root*)
(lambda (msg) (funcall #'handle-message *root* msg))
:foreground t))
(shutdown))) (shutdown)))
(defun shutdown () (defun shutdown ()

2
web/client.lisp
View file

@ -15,7 +15,7 @@
(defvar *cookie-jar* (cl-cookie:make-cookie-jar)) (defvar *cookie-jar* (cl-cookie:make-cookie-jar))
(defclass config (config:base) (defclass config (config:base)
((config:setup :initform (core:make-setup :class 'core:service)) ((config:setup :initform (core:make-setup :class 'core:context))
(base-url :reader base-url :initarg :base-url :initform "http://localhost:8135") (base-url :reader base-url :initarg :base-url :initform "http://localhost:8135")
(doc-path :reader doc-path :initarg :doc-path :initform "/") (doc-path :reader doc-path :initarg :doc-path :initform "/")
(api-path :reader api-path :initarg :api-path :initform "/api/") (api-path :reader api-path :initarg :api-path :initform "/api/")

12
web/response.lisp
View file

@ -6,6 +6,7 @@
(:cookie :scopes/web/cookie) (:cookie :scopes/web/cookie)
(:core :scopes/core) (:core :scopes/core)
(:dom :scopes/web/dom) (:dom :scopes/web/dom)
(:lpq :lparallel.queue)
(:message :scopes/core/message) (:message :scopes/core/message)
(:shape :scopes/shape) (:shape :scopes/shape)
(:util :scopes/util)) (:util :scopes/util))
@ -71,8 +72,11 @@
(defun setup (ctx env &key html-responder) (defun setup (ctx env &key html-responder)
(let* ((headers (getf env :headers)) (let* ((headers (getf env :headers))
(resp-class (select-response-class (gethash "accept" headers) html-responder))) (resp-class (select-response-class (gethash "accept" headers) html-responder))
(actor:make-actor #'core:handle-message resp-class :context ctx :env env))) (resp (make-instance resp-class :context ctx :env env)))
(setf (core:mailbox resp) (lpq:make-queue))
resp))
;(actor:make-actor #'core:handle-message resp-class :context ctx :env env)))
(defun select-response-class (accept html-responder) (defun select-response-class (accept html-responder)
(let ((accept (string-downcase accept))) (let ((accept (string-downcase accept)))
@ -100,7 +104,9 @@
(defun render (resp) (defun render (resp)
#'(lambda (responder) #'(lambda (responder)
(setf (responder resp) responder) (setf (responder resp) responder)
(actor:start resp))) (actor:start (core:mailbox resp)
(lambda (msg) (funcall #'core:handle-message resp msg))
:foreground t)))
(defun render-not-found(resp) (defun render-not-found(resp)
(list 404 '(:content-type "text/plain") '("Not found"))) (list 404 '(:content-type "text/plain") '("Not found")))

7
web/server.lisp
View file

@ -29,7 +29,7 @@
((listener :accessor listener))) ((listener :accessor listener)))
(defun setup (cfg) (defun setup (cfg)
(let ((ctx (core:default-setup cfg 'context))) (let ((ctx (funcall (core:make-setup :class 'context) cfg)))
(start ctx))) (start ctx)))
;;;; listener = server process ;;;; listener = server process
@ -89,8 +89,9 @@
(defun message-handler (ctx env &key html-responder) (defun message-handler (ctx env &key html-responder)
(let* ((resp (response:setup ctx env :html-responder html-responder)) (let* ((resp (response:setup ctx env :html-responder html-responder))
(msg (message:create (msg (message:create (head env)
(head env) :data (plist (post-data env)) :customer resp))) :data (plist (post-data env))
:customer (core:mailbox resp))))
(util:lgd msg) (util:lgd msg)
; (check-auth ctx msg env) => (response:render-unauthorized resp) ; (check-auth ctx msg env) => (response:render-unauthorized resp)
(if (core:handle-message ctx msg) (if (core:handle-message ctx msg)