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

make html-responder (HTML response class) configurable; use cs-hx:response in demo app

Browse source
This commit is contained in:
Helmut Merz 2024-07-18 19:18:33 +02:00
parent 3217a16002
commit 5ee58b2437
6 changed files with 31 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
app/demo/etc/config.lisp
View file

@ -12,8 +12,7 @@
:port "8800" :port "8800"
:address "0.0.0.0" :address "0.0.0.0"
:routes :routes
`((("api") server:message-handler) `((("api") server:message-handler :html-responder cs-hx:response)
(() server:fileserver :doc-root (() server:fileserver :doc-root
;,(util:path-from-string (config:from-env :docroot "/var/www/html/")))))
,(config:path "/var/www/html/" :env-key :docroot)))) ,(config:path "/var/www/html/" :env-key :docroot))))
(config:add-action '(:test :data) #'core:echo) (config:add-action '(:test :data) #'core:echo)

1
app/demo/main.lisp
View file

@ -3,6 +3,7 @@
(defpackage :scopes/app/demo (defpackage :scopes/app/demo
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:config :scopes/config) (:local-nicknames (:config :scopes/config)
(:cs-hx :scopes/frontend/cs-hx)
(:core :scopes/core) (:core :scopes/core)
(:forge :scopes/forge) (:forge :scopes/forge)
(:logging :scopes/logging) (:logging :scopes/logging)

13
frontend/cs-hx.lisp Normal file
View file

@ -0,0 +1,13 @@
;;;; cl-scopes/frontend/cs-hx - frontend (http response) definitions
;;;; for embedding HTML fragments in pages generated by the `cyberscopes` Hugo theme
;;;; with dynamic elements handled by `HTMX`.
(defpackage :scopes/frontend/cs-hx
(:use :common-lisp)
(:local-nicknames (:dom :scopes/web/dom)
(:response :scopes/web/response))
(:export #:render-content #:response))
(in-package :scopes/frontend/cs-hx)
(defclass response (response:html-response) ())

3
scopes-web.asd
View file

@ -9,7 +9,8 @@
:depends-on (:clack :dexador :flexi-streams :depends-on (:clack :dexador :flexi-streams
:lack :lack-component :lack-app-file :quri :lack :lack-component :lack-app-file :quri
:scopes-core) :scopes-core)
:components ((:file "web/client") :components ((:file "frontend/cs-hx" :depends-on ("web/dom" "web/response"))
(:file "web/client")
(:file "web/dom") (:file "web/dom")
(:file "web/response" :depends-on ("web/dom")) (:file "web/response" :depends-on ("web/dom"))
(:file "web/server" :depends-on ("web/response"))) (:file "web/server" :depends-on ("web/response")))

18
web/response.lisp
View file

@ -5,10 +5,13 @@
(:local-nicknames (:dom :scopes/web/dom) (:local-nicknames (:dom :scopes/web/dom)
(:message :scopes/core/message)) (:message :scopes/core/message))
(:export #:setup (:export #:setup
#:render #:render-not-found)) #:html-response
#:render #:render-content #:render-not-found))
(in-package :scopes/web/response) (in-package :scopes/web/response)
(defvar *html-response-class* nil)
(defclass response () (defclass response ()
((context :reader context :initarg :context) ((context :reader context :initarg :context)
(env :reader env :initarg :env) (env :reader env :initarg :env)
@ -32,18 +35,21 @@
;;;; common definitions ;;;; common definitions
(defun setup (ctx env) (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)))) (resp-class (select-response-class (gethash "accept" headers) html-responder)))
(make-instance resp-class :context ctx :env env))) (make-instance resp-class :context ctx :env env)))
(defun select-response-class (accept) (defun select-response-class (accept html-responder)
(let ((accept (string-downcase accept))) (let ((accept (string-downcase accept)))
(cond (cond
((str:containsp "html" accept) 'html-response) ((str:containsp "html" accept) (html-response-class html-responder))
((str:containsp "json" accept) 'json-response) ((str:containsp "json" accept) 'json-response)
((str:containsp "plain" accept) 'plain-text-response) ((str:containsp "plain" accept) 'plain-text-response)
(t 'html-response)))) (t (html-response-class html-responder)))))
(defun html-response-class (html-responder)
(or html-responder *html-response-class* 'html-response))
(defun render (resp msg) (defun render (resp msg)
; process special message heads, e.g. (:system :error ...) ; process special message heads, e.g. (:system :error ...)

5
web/server.lisp
View file

@ -76,17 +76,16 @@
(tail (last message-head))) (tail (last message-head)))
(if (string= (car tail) "") (if (string= (car tail) "")
(setf (car tail) "index.html")) (setf (car tail) "index.html"))
(log:debug "doc-root: ~s" doc-root)
(let* ((rel-path (str:join "/" message-head)) (let* ((rel-path (str:join "/" message-head))
(file-app (make-instance 'lack/app/file:lack-app-file (file-app (make-instance 'lack/app/file:lack-app-file
:file rel-path :root doc-root))) :file rel-path :root doc-root)))
(lack/component:call file-app env)))) (lack/component:call file-app env))))
(defun message-handler (ctx env &key html-renderer) (defun message-handler (ctx env &key html-responder)
(let* ((iact (make-instance 'interaction)) (let* ((iact (make-instance '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))) (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)