104 lines
3.4 KiB
Common Lisp
104 lines
3.4 KiB
Common Lisp
;;;; cl-scopes/web/response - set up and render server response
|
|
|
|
(defpackage :scopes/web/response
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:cookie :scopes/web/cookie)
|
|
(:core :scopes/core)
|
|
(:dom :scopes/web/dom)
|
|
(:message :scopes/core/message)
|
|
(:shape :scopes/shape)
|
|
(:util :scopes/util))
|
|
(:export #:interaction #:setup #:html-response
|
|
#:render #:render-content #:render-not-found))
|
|
|
|
(in-package :scopes/web/response)
|
|
|
|
;;;; server interaction - receive response message from action processing chain
|
|
;;; predefined action handlers / default actions
|
|
|
|
(defun render-msg (ia msg)
|
|
(push msg (messages ia)))
|
|
|
|
(defun set-cookie (ia msg)
|
|
(util:plist-add (headers (response ia))
|
|
:set-cookie (render-cookie (shape:data msg))))
|
|
|
|
(defvar *interaction-default-actions*
|
|
(core:define-actions '((:response :set-cookie) set-cookie)
|
|
'(nil render-msg)))
|
|
|
|
;;; interaction class and methods
|
|
|
|
(defclass interaction (core:base-context)
|
|
((core:actions :initform *interaction-default-actions*)
|
|
(response :reader response :initarg :response)
|
|
(messages :accessor messages :initform nil)))
|
|
|
|
(defmethod print-object ((ia interaction) s)
|
|
(shape:print-fields ia s 'messages))
|
|
|
|
(defun render-cookie (cdata)
|
|
(let ((cookie (apply #'cookie:create-from-keys cdata)))
|
|
(cookie:make-header cookie)))
|
|
|
|
;;;; response definitions
|
|
|
|
(defvar *html-response-class* nil)
|
|
|
|
(defclass response ()
|
|
((context :reader context :initarg :context)
|
|
(env :reader env :initarg :env)
|
|
(headers :accessor headers :initform nil)
|
|
(ctype :reader ctype :allocation :class)))
|
|
|
|
(defgeneric render-content (resp msg))
|
|
|
|
(defclass plain-text-response (response)
|
|
((ctype :initform "text/plain")))
|
|
|
|
(defclass json-response (response)
|
|
((ctype :initform "application/json")))
|
|
|
|
;;;; html response
|
|
|
|
(defclass html-response (response)
|
|
((ctype :initform "text/html")))
|
|
|
|
(defmethod render-content ((resp html-response) msg)
|
|
(dom:render (dom:dlist nil (shape:data msg))))
|
|
|
|
;;;; common definitions
|
|
|
|
(defun setup (ctx env &key html-responder)
|
|
(let* ((headers (getf env :headers))
|
|
(resp-class (select-response-class (gethash "accept" headers) html-responder)))
|
|
(make-instance resp-class :context ctx :env env)))
|
|
|
|
(defun select-response-class (accept html-responder)
|
|
(let ((accept (string-downcase accept)))
|
|
(cond
|
|
((str:containsp "html" accept) (html-response-class html-responder))
|
|
((str:containsp "json" accept) 'json-response)
|
|
((str:containsp "plain" accept) 'plain-text-response)
|
|
(t (html-response-class html-responder)))))
|
|
|
|
(defun html-response-class (html-responder)
|
|
(or html-responder *html-response-class* 'html-response))
|
|
|
|
(defun make-headers (resp)
|
|
(cons :content-type (cons (ctype resp) (headers resp))))
|
|
|
|
(defun render (resp iact)
|
|
; pre-process special message heads, e.g. (:system :error ...)
|
|
; => set status code, provide additional data elements
|
|
; set additional headers (<- will be done by interaction)
|
|
(let ((headers (make-headers resp))
|
|
(rcode 200))
|
|
#'(lambda (responder)
|
|
(let ((writer (funcall responder (list rcode headers))))
|
|
(dolist (msg (messages iact))
|
|
(funcall writer (render-content resp msg)))
|
|
(funcall writer nil :close t)))))
|
|
|
|
(defun render-not-found(resp)
|
|
(list 404 '(:content-type "text/plain") '("Not found")))
|