feat(web/panettone): Render issues+comments as Markdown r/1511

Use the new cheddar markdown endpoint to render issue bodies and comment
bodies as JSON. I've checked, and this *also* appears to be XSS
safe (yay)

Change-Id: Ib4b19fd581b0cf40ba03f5d13443535d17df6632
Reviewed-on: https://cl.tvl.fyi/c/depot/+/1500
Reviewed-by: tazjin <mail@tazj.in>
Tested-by: BuildkiteCI

3 files changed, 64 insertions, 4 deletions

diff --git a/web/panettone/default.nix b/web/panettone/default.nix
index 4d40209231..4f6faaea32 100644
--- a/web/panettone/default.nix
+++ b/web/panettone/default.nix
@@ -4,6 +4,7 @@ depot.nix.buildLisp.program {
   name = "panettone";
 
   deps = with depot.third_party.lisp; [
+    cl-json
     cl-who
     drakma
     defclass-std
diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp
index 327ea023b2..16cb39dec5 100644
--- a/web/panettone/src/packages.lisp
+++ b/web/panettone/src/packages.lisp
@@ -40,7 +40,7 @@
         :panettone.util
         :panettone.authentication)
   (:import-from :defclass-std :defclass/std)
-  (:import-from :alexandria :if-let :when-let :switch)
+  (:import-from :alexandria :if-let :when-let :switch :alist-hash-table)
   (: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 6be9cf659b..c43934a20b 100644
--- a/web/panettone/src/panettone.lisp
+++ b/web/panettone/src/panettone.lisp
@@ -1,6 +1,62 @@
 (in-package :panettone)
 (declaim (optimize (safety 3)))
 
+(defvar *cheddar-url* "http://localhost:4238")
+
+(defgeneric render-markdown (markdown)
+  (:documentation
+   "Render the argument, or the elements of the argument, as markdown, and return
+   the same structure"))
+
+(defmethod render-markdown ((markdown string))
+  (cdr
+   (assoc :markdown
+          (cl-json:decode-json
+           (drakma:http-request
+            (concatenate 'string
+                         *cheddar-url*
+                         "/markdown")
+            :accept "application/json"
+            :method :post
+            :content-type "application/json"
+            :external-format-out :utf-8
+            :external-format-in :utf-8
+            :content (json:encode-json-to-string
+                      `((markdown . ,markdown)))
+            :want-stream t)))))
+
+(defmethod render-markdown ((markdown hash-table))
+  (alist-hash-table
+   (cl-json:decode-json
+    (drakma:http-request
+     (concatenate 'string
+                  *cheddar-url*
+                  "/markdown")
+     :accept "application/json"
+     :method :post
+     :content-type "application/json"
+     :external-format-out :utf-8
+     :external-format-in :utf-8
+     :content (json:encode-json-to-string markdown)
+     :want-stream t))))
+
+(defun markdownify-comment-bodies (comments)
+  "Convert the bodies of the given list of comments to markdown in-place using
+  Cheddar, and return nothing"
+  (let ((in (make-hash-table))
+        (comment-table (make-hash-table)))
+    (dolist (comment comments)
+      (check-type comment model:issue-comment)
+      (setf (gethash (id comment) in) (body comment))
+      (setf (gethash (id comment) comment-table) comment))
+    (let ((res (render-markdown in)))
+      (iter (for (comment-id markdown-body) in-hashtable res)
+        (let ((comment-id (parse-integer (symbol-name comment-id))))
+          (setf (slot-value (gethash comment-id comment-table)
+                            'model:body)
+                markdown-body)))))
+  (values))
+
 ;;;
 ;;; Views
 ;;;
@@ -196,7 +252,7 @@
     (who:htm
      (:li
       :class "comment"
-      (:p (who:esc (body comment)))
+      (:p (who:str (body comment)))
       (:p
        :class "comment-info"
        (:span :class "username"
@@ -249,7 +305,7 @@
                           :value (case issue-status
                                    (:open "Close")
                                    (:closed "Reopen")))))))
-       (:p (who:esc (body issue)))
+       (:p (who:str (render-markdown (body issue))))
        (let* ((comments (issue-comments issue))
               (events (issue-events issue))
               (history (merge 'list
@@ -257,6 +313,7 @@
                               events
                               #'local-time:timestamp<
                               :key #'created-at)))
+         (markdownify-comment-bodies comments)
          (who:htm
           (:ol
            :class "issue-history"
@@ -410,7 +467,9 @@
 
 (defun main ()
   (let ((port (integer-env "PANETTONE_PORT" :default 6161))
-        (ldap-port (integer-env "LDAP_PORT" :default 389)))
+        (ldap-port (integer-env "LDAP_PORT" :default 389))
+        (cheddar-url (uiop:getenvp "CHEDDAR_URL")))
+    (when cheddar-url (setq *cheddar-url* cheddar-url))
     (setq hunchentoot:*show-lisp-backtraces-p* nil)
     (setq hunchentoot:*log-lisp-backtraces-p* nil)
     (start-panettone :port port