src/response.lisp

   1 (uiop:define-package #:lw2.response
   2     (:use #:cl #:lw2.utils #:lw2.conditions #:lw2.sites #:lw2.routes)
   3   (:import-from #:lw2.html-reader #:*html-output*)
   4   (:export #:with-response-context #:with-response-stream #:define-json-endpoint)
   5   (:recycle #:lw2-viewer))
   6
   7 (in-package #:lw2.response)
   8
   9 (defun call-with-response-context (fn)
  10   (with-site-context ((let ((host (or (hunchentoot:header-in* :x-forwarded-host) (hunchentoot:header-in* :host))))
  11                         (or (find-site host)
  12                             (error "Unknown site: ~A" host))))
  13     (funcall fn)))
  14
  15 (defmacro with-response-context (() &body body)
  16   `(dynamic-flet ((fn () ,@body)) (call-with-response-context #'fn)))
  17
  18 (defun call-with-response-stream (fn)
  19   (unless (eq (hunchentoot:request-method*) :head)
  20     (let ((*html-output* (flex:make-flexi-stream (hunchentoot:send-headers) :external-format :utf-8)))
  21       (handler-case
  22           (funcall fn *html-output*)
  23         (serious-condition () (close *html-output*))
  24         (:no-error (&rest x) (declare (ignore x)) (finish-output *html-output*))))))
  25
  26 (defmacro with-response-stream ((out-stream) &body body) `(dynamic-flet ((fn (,out-stream) ,@body)) (call-with-response-stream #'fn)))
  27
  28 (defun serve-json-request (fn)
  29   (with-response-context ()
  30     (let ((result
  31            (handler-case (funcall fn)
  32              (fatal-error (condition)
  33                (setf (hunchentoot:return-code*) (condition-http-return-code condition))
  34                (list-cond (t :error (princ-to-string condition))
  35                           #|todo (*debug-mode* :backtrace ...)|#)))))
  36       (setf (hunchentoot:content-type*) "application/json")
  37       (with-response-stream (out-stream)
  38         (json:encode-json result out-stream)))))
  39
  40 (defmacro define-json-endpoint ((name site-class uri) &body body)
  41   `(define-route ',site-class 'standard-route :name ',name :uri ,uri
  42                  :handler (lambda () (dynamic-flet ((fn () ,@body)) (serve-json-request #'fn)))))