From 77c09076eccf343e7f14ed389719c0866de3d649 Mon Sep 17 00:00:00 2001
From: Griffin Smith <grfn@gws.fyi>
Date: Sun, 18 Apr 2021 17:27:45 +0200
Subject: feat(web/panettone): Allow requesting JSON

Allow specifying an `Accept: application/json` header to the index and
show issue routes, to request that those pages be returned as JSON.

Change-Id: Ic225139fc9e7fdce0da98984df4ca987685dafe0
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3043
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>
Reviewed-by: tazjin <mail@tazj.in>
---
 web/panettone/src/packages.lisp  |  4 +++-
 web/panettone/src/panettone.lisp | 41 +++++++++++++++++++++++++++++++++++++---
 2 files changed, 41 insertions(+), 4 deletions(-)

(limited to 'web/panettone')

diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp
index 3e6aa4a05f4f..a428c188c050 100644
--- a/web/panettone/src/packages.lisp
+++ b/web/panettone/src/packages.lisp
@@ -69,9 +69,11 @@
         :panettone.authentication
         :panettone.inline-markdown)
   (:import-from :defclass-std :defclass/std)
-  (:import-from :alexandria :if-let :when-let :switch :alist-hash-table)
+  (:import-from :alexandria :if-let :when-let :switch :alist-hash-table
+                :assoc-value :eswitch)
   (:import-from :cl-ppcre :split)
   (:import-from :bordeaux-threads :make-thread)
+  (:import-from :cl-json :encode-json :encode-json-to-string)
   (:import-from
    :panettone.model
    :id :subject :body :author-dn :issue-id :status :created-at
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
index 3d803e1fb6a9..d6713407a57d 100644
--- a/web/panettone/src/panettone.lisp
+++ b/web/panettone/src/panettone.lisp
@@ -50,12 +50,43 @@
                 markdown-body)))))
   (values))
 
+;;;
+;;; Responses
+;;;
+
+(defun request-format ()
+  "Returns the content type requested by the current hunchentoot request as a
+symbol equal to either `:html' or `:json', defaulting to `:html' if not
+specified."
+  (eswitch ((hunchentoot:header-in* :accept) :test #'equal)
+    ("application/json" :json)
+    ("text/html" :html)
+    ("*/*" :html)))
+
+(defun format->mime (format)
+  (ecase format
+    (:json "application/json")
+    (:html "text/html")))
+
+(defmacro format-case (&rest clauses)
+  "Execute the cdr of the element in CLAUSES whose car is equal to the current
+request format, a symbol that can be either `:JSON' or `:HTML'"
+  (let ((format (gensym "format")))
+    `(let ((,format (request-format)))
+       (setf (hunchentoot:content-type*) (format->mime ,format))
+       (case ,format ,@clauses))))
+
+(defmethod encode-json ((ts local-time:timestamp)
+                        &optional (stream json:*json-output*))
+  (encode-json (local-time:format-rfc3339-timestring
+                nil ts)
+               stream))
+
 ;;;
 ;;; Views
 ;;;
 
 (defvar *title* "Panettone")
-
 (setf (who:html-mode) :html5)
 
 (defun render/nav ()
@@ -469,7 +500,9 @@ given subject an body (in a thread, to avoid blocking)"
 
 (defroute index ("/" :decorators (@auth-optional)) ()
   (let ((issues (model:list-issues :status :open)))
-    (render/index :issues issues)))
+    (format-case
+     (:html (render/index :issues issues))
+     (:json (encode-json-to-string issues)))))
 
 (defroute settings ("/settings" :method :get :decorators (@auth)) ()
   (render/settings))
@@ -518,7 +551,9 @@ given subject an body (in a thread, to avoid blocking)"
   (let* ((issue (model:get-issue id))
          (*title* (format nil "~A | Panettone"
                           (subject issue))))
-    (render/issue issue)))
+    (format-case
+     (:html (render/issue issue))
+     (:json (encode-json-to-string issue)))))
 
 (defroute edit-issue
     ("/issues/:id/edit" :decorators (@auth @handle-issue-not-found))
-- 
cgit 1.4.1