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

web/response: provide dynamic response via responder / writer calls

Browse source
This commit is contained in:
Helmut Merz 2024-07-26 08:51:08 +02:00
parent e9f9abd4a0
commit 7c4b22d5f8
2 changed files with 27 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
web/response.lisp
View file

@ -2,11 +2,11 @@
(defpackage :scopes/web/response (defpackage :scopes/web/response
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:dom :scopes/web/dom) (:local-nicknames (:core :scopes/core)
(:dom :scopes/web/dom)
(:message :scopes/core/message) (:message :scopes/core/message)
(:shape :scopes/shape)) (:shape :scopes/shape))
(:export #:setup (:export #:interaction #:setup #:html-response
#:html-response
#:render #:render-content #:render-not-found)) #:render #:render-content #:render-not-found))
(in-package :scopes/web/response) (in-package :scopes/web/response)
@ -26,6 +26,18 @@
(defclass json-response (response) (defclass json-response (response)
((ctype :initform "application/json"))) ((ctype :initform "application/json")))
;;;; server interaction - receive response message from action processing chain
(defclass interaction ()
((messages :accessor messages :initform nil)))
(defmethod print-object ((ia interaction) s)
(format s "<interaction ~s>" (messages ia)))
(defmethod core:send ((ia interaction) msg)
(log:debug "receiving ~s" msg)
(push msg (messages ia)))
;;;; html response ;;;; html response
(defclass html-response (response) (defclass html-response (response)
@ -52,15 +64,19 @@
(defun html-response-class (html-responder) (defun html-response-class (html-responder)
(or html-responder *html-response-class* 'html-response)) (or html-responder *html-response-class* 'html-response))
(defun render (resp msgs) (defun render (resp iact)
; process special message heads, e.g. (:system :error ...) ; pre-process special message heads, e.g. (:system :error ...)
; => set status code, provide additional data elements ; => set status code, provide additional data elements
; set additional headers ; set additional headers
(let ((headers (list :content-type (ctype resp))) (let ((headers (list :content-type (ctype resp)))
(rcode 200) (rcode 200))
(content (mapcar #'(lambda (m) (render-content resp m)) msgs))) #'(lambda (responder)
;(content (render-content resp msg))) (let ((writer (funcall responder (list rcode headers))))
(list rcode headers content))) (dolist (msg (messages iact))
(funcall writer (render-content resp msg)))
(funcall writer nil :close t)))))
; (content (mapcar #'(lambda (m) (render-content resp m)) (messages iact))))
;(list rcode headers content)))
(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")))

17
web/server.lisp
View file

@ -83,29 +83,16 @@
(lack/component:call file-app env)))) (lack/component:call file-app env))))
(defun message-handler (ctx env &key html-responder) (defun message-handler (ctx env &key html-responder)
(let* ((iact (make-instance 'interaction)) (let* ((iact (make-instance 'response:interaction))
(msg (message:create (msg (message:create
(head env) :data (plist (post-data env)) :sender iact)) (head env) :data (plist (post-data env)) :sender iact))
(resp (response:setup ctx env :html-responder html-responder))) (resp (response:setup ctx env :html-responder html-responder)))
(log:debug "msg ~s" msg) (log:debug "msg ~s" 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)
(response:render resp (messages iact)) (response:render resp iact)
(response:render-not-found resp)))) (response:render-not-found resp))))
;;;; server interaction - receive response message from action processing chain
(defclass interaction ()
((messages :accessor messages :initform nil)))
(defmethod print-object ((ia interaction) s)
(format s "<interaction ~s>" (messages ia)))
(defmethod core:send ((ia interaction) msg)
(log:debug "receiving ~s" msg)
(push msg (messages ia)))
;(setf (message ia) msg))
;;;; helper functions ;;;; helper functions
(defun head (env) (defun head (env)