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

(defpackage :scopes/web/response
  (:use :common-lisp)
  (:local-nicknames (: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

(defclass interaction (core:base-context)
  ((core:default-actions :initform 
     (list (make-instance 'core:action-spec :handlers (list #'store-msg))))
   (response :reader response :initarg :response)
   (messages :accessor messages :initform nil)))

(defmethod print-object ((ia interaction) s)
  (shape:print-fields ia s 'messages))

(defun store-msg (ia msg)
  (push msg (messages ia)))

(defun add-cookies (iact)
  (let ((headers (resp (response iact))))
    (dolist (cdata (cookie-data iact))
      (setf headers 
            (cons :set-cookie (cons (render-cookie iact cdata) headers))))
    headers))

(defun render-cookie (iact cdata)
  "DEMO=1234567; Path=/; Domain=testing.cyberscopes.org")

(defun cookie-data (ia)
  (let ((c nil))
    c))

;;;; 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
  (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")))