diff --git a/test/etc/config-web.lisp b/test/etc/config-web.lisp index 9fb3aab..761c957 100644 --- a/test/etc/config-web.lisp +++ b/test/etc/config-web.lisp @@ -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" diff --git a/test/test-web.lisp b/test/test-web.lisp index 0564e97..efa40c1 100644 --- a/test/test-web.lisp +++ b/test/test-web.lisp @@ -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"))) diff --git a/web/server.lisp b/web/server.lisp index 9c3d7da..de2d6e6 100644 --- a/web/server.lisp +++ b/web/server.lisp @@ -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 "" (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 "" (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