diff --git a/scopes-web.asd b/scopes-web.asd index 69adb24..e362b74 100644 --- a/scopes-web.asd +++ b/scopes-web.asd @@ -10,7 +10,8 @@ :lack :lack-component :lack-app-file :quri :scopes-core) :components ((:file "web/client") - (:file "web/server")) + (:file "web/response") + (:file "web/server" :depends-on ("web/response"))) :long-description "scopes/web: Web server and web/API/REST client." :in-order-to ((test-op (test-op "scopes-web/test")))) diff --git a/web/response.lisp b/web/response.lisp new file mode 100644 index 0000000..4c23a77 --- /dev/null +++ b/web/response.lisp @@ -0,0 +1,43 @@ +;;;; cl-scopes/web/response - set up and render server response + +(defpackage :scopes/web/response + (:use :common-lisp) + (:local-nicknames (:message :scopes/core/message)) + (:export #:setup + #:render #:render-not-found)) + +(in-package :scopes/web/response) + +(defclass plain-text-response () + ((context :initarg :context) + (env :initarg :env))) + +(defclass json-response (plain-text-response) ()) + +(defclass html-response (plain-text-response) ()) + +(defun setup (ctx env) + (let* ((headers (getf env :headers)) + (resp-class (select-response-class (gethash "accept" headers)))) + (make-instance resp-class :context ctx :env env))) + +(defun select-response-class (accept) + (cond + ((null accept) 'html-response) + ((str:containsp "html" accept) 'html-response) + ((str:containsp "json" accept) 'json-response) + ((str:containsp "plain" accept) 'plain-text-response) + (t 'html-response))) + +(defun render (resp msg) + (let ((headers '(:content-type "text/plain")) + (rcode 200) + (content (getf (message:data msg) :info))) + ; process special message heads, e.g. (:system :error ...) + ; => set status code, provide additional data elements + ; (gethash "accept" (getf env :headers)) => select output format + ; set headers, render body + (list rcode headers (list content)))) + +(defun render-not-found(resp) + (list 404 '(:content-type "text/plain") '("Not found"))) diff --git a/web/server.lisp b/web/server.lisp index c28aa51..854e38d 100644 --- a/web/server.lisp +++ b/web/server.lisp @@ -5,6 +5,7 @@ (:local-nicknames (:config :scopes/config) (:core :scopes/core) (:message :scopes/core/message) + (:response :scopes/web/response) (:util :scopes/util) (:alx :alexandria)) (:export #:config #:address #:port #:routes @@ -83,14 +84,15 @@ (defun message-handler (ctx env) (let* ((iact (make-instance 'interaction)) (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))) (log:debug "msg ~s" msg) - ; (check-auth ctx msg env) => (render-unauthorized ctx msg env) + ; (check-auth ctx msg env) => (response:render-unauthorized resp) (if (core:handle-message ctx msg) - (render ctx (message iact) env) - (render-not-found ctx env)))) + (response:render resp (message iact)) + (response:render-not-found resp)))) -;;;; server interaction and response - provide response data and render body and headers +;;;; server interaction - receive response message from action processing chain (defclass interaction () ((message :accessor message :initform nil))) @@ -102,19 +104,6 @@ (log:debug "receiving ~s" msg) (setf (message ia) msg)) -(defun render (ctx msg env) - (let ((headers '(:content-type "text/plain")) - (rcode 200) - (content (getf (message:data msg) :info))) - ; process special message heads, e.g. (:system :error ...) - ; => set status code, provide additional data elements - ; (gethash "accept" (getf env :headers)) => select output format - ; set headers, render body - (list rcode headers (list content)))) - -(defun render-not-found(ctx env) - (list 404 '(:content-type "text/plain") '("Not found"))) - ;;;; helper functions (defun head (env)