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

minor refactoring; prepare response handling

Browse source
This commit is contained in:
Helmut Merz 2024-07-07 22:03:46 +02:00
parent 4d199a1d92
commit 3b98c9cc54
3 changed files with 44 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
test/etc/config-web.lisp
View file

@ -16,7 +16,6 @@
(() server:fileserver
:doc-root ,(t:test-path "" "docs"))))
(config:add-action '(:test :data) #'core:echo)
;(config:add-action '(:test :data) #'(lambda (ctx msg)))
(config:add :client :class 'client:config
:base-url "http://localhost:8899"

2
test/test-web.lisp
View file

@ -41,5 +41,5 @@
(has-prefix (client:get-page client msg) "Hello Fileserver!")))
(deftest test-message (client)
(let ((msg (message:create '(:test :data) :data '(:info "test data"))))
(let ((msg (message:create '(:test :data :field :info) :data '(:info "test data"))))
(== (client:send-message client msg) "test data")))

78
web/server.lisp
View file

@ -22,6 +22,15 @@
(port :reader port :initarg :port :initform "8888")
(routes :reader routes :initarg :routes :initform nil)))
;;;; server context (= service), action handlers
(defclass context (core:context)
((listener :accessor listener)))
(defun setup (cfg)
(let ((ctx (make-instance 'context :config cfg :name (config:name cfg))))
(start ctx)))
;;;; listener = server process
(defun app (ctx env)
@ -46,27 +55,6 @@
(defun stop (ctx)
(clack:stop (listener ctx)))
(defun fileserver (ctx env &key doc-root)
(let* ((message-head (getf env :message-head))
(tail (last message-head)))
(if (string= (car tail) "")
(setf (car tail) "index.html"))
(let* ((rel-path (str:join "/" message-head))
(file-app (make-instance 'lack/app/file:lack-app-file
:file rel-path :root doc-root)))
(lack/component:call file-app env))))
(defun message-handler (ctx env)
(let* ((resp (make-instance 'response))
(msg (message:create
(head env) :data (plist (post-data env)) :sender resp)))
(log:debug "msg ~s" msg)
(if (core:handle-message ctx msg)
;(render-response ctx resp)
(list 200 (headers resp) (list (body resp)))
(list 404 '(:content-type "text/plain") '("Not found")))))
;(render-not-found ctx)
(defun select-app (ctx env)
(let ((path (cdr (str:split "/" (getf env :path-info)))))
(dolist (r (routes (core:config ctx)))
@ -82,31 +70,51 @@
(return-from match nil)))
t)
;;;; server response - provice response body and headers
(defun fileserver (ctx env &key doc-root)
(let* ((message-head (getf env :message-head))
(tail (last message-head)))
(if (string= (car tail) "")
(setf (car tail) "index.html"))
(let* ((rel-path (str:join "/" message-head))
(file-app (make-instance 'lack/app/file:lack-app-file
:file rel-path :root doc-root)))
(lack/component:call file-app env))))
(defun message-handler (ctx env)
(let* ((resp (make-instance 'response))
(msg (message:create
(head env) :data (plist (post-data env)) :sender resp)))
(log:debug "msg ~s" msg)
; (check-auth ctx msg env) => (render-unauthorized ctx msg env)
(if (core:handle-message ctx msg)
;(render ctx (message resp) env)
(list 200 (headers resp) (list (body resp)))
(list 404 '(:content-type "text/plain") '("Not found")))))
;(render-not-found ctx env)
;;;; server response - provide response data for rendering body and headers
(defclass response ()
((message :accessor message :initform nil)
(headers :accessor headers :initform '(:content-type "text/plain"))))
(defgeneric body (r)
(:method ((r response))
(getf (message:data (message r)) :info)))
(defmethod print-object ((r response) s)
(format s "<response ~s>" (message r)))
(defmethod core:send ((r response) msg)
(log:debug "receiving ~s" msg)
(setf (message r) msg))
(defmethod print-object ((r response) s)
(format s "<response ~s>" (message r)))
(defgeneric body (r)
(:method ((r response))
(getf (message:data (message r)) :info)))
;;;; server context (= service), action handlers
(defclass context (core:context)
((listener :accessor listener)))
(defun setup (cfg)
(let ((ctx (make-instance 'context :config cfg :name (config:name cfg))))
(start ctx)))
(defun render (ctx msg env)
; process special message headers, e.g. (:system :error ...)
; => set status code, provide additional data elements
; (gethash "accept" (getf env :headers)) => select output format
; set headers, render body
)
;;;; helper functions