;;;; cl-scopes/web/response - set up and render server response

(defpackage :scopes/web/response
  (:use :common-lisp)
  (:local-nicknames (:actor :scopes/core/actor)
                    (:cookie :scopes/web/cookie)
                    (:core :scopes/core)
                    (:dom :scopes/web/dom)
                    (:message :scopes/core/message)
                    (:shape :scopes/shape)
                    (:util :scopes/util))
  (:export #:setup #:html-response
           #:render #:render-content #:render-not-found))

(in-package :scopes/web/response)

;;;; predefined action handlers / default actions

(defun render-msg (resp msg)
  (if msg 
    (push msg (messages resp)))
  (prepare resp)
  (finish resp))

(defun set-cookie (resp msg)
  (util:plist-add (headers resp) 
                  :set-cookie (render-cookie (shape:data msg)))
  (render-msg resp nil))

(defvar *default-actions* 
  (core:define-actions '((:response :set-cookie) set-cookie) 
                       '(nil render-msg)))

(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 (core:base-context actor:fg-actor)
  ((context :reader context :initarg :context)
   (core:actions :initform *default-actions*)
   (env :reader env :initarg :env)
   (messages :accessor messages :initform nil)
   (headers :accessor headers :initform nil)
   (ctype :reader ctype :allocation :class)
   (responder :accessor responder)
   (writer :accessor writer)))

(defmethod print-object ((resp response) s)
  (shape:print-fields resp s 'messages))

(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)))
    (actor:make-actor #'core:handle-message 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 prepare (resp)
  (let ((headers (make-headers resp))
        (rcode 200))
    (setf (writer resp) (funcall (responder resp) (list rcode headers)))))

(defun finish (resp)
  (dolist (msg (messages resp))
    (funcall (writer resp) (render-content resp msg)))
  (funcall (writer resp) nil :close t)
  (actor:stop resp))

(defun render (resp)
  #'(lambda (responder)
      (setf (responder resp) responder)
      (actor:start resp)))

(defun render-not-found(resp)
  (list 404 '(:content-type "text/plain") '("Not found")))