feat(web/panettone): Display issue history

Display the history of an issue (which currently is just opening and
closing) inline with the issue's comments on the issue show page

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

lisp/klatre/klatre.lisp

@@ -94,3 +94,13 @@ separated by SEP."
   (check-type str string)
   (handler-case (parse-integer str)
     (sb-int:simple-parse-error (_) nil)))
+
+;;;
+;;; Function utilities
+;;;
+
+(defun partial (f &rest args)
+  "Return a function that calls F with ARGS prepended to any remaining
+  arguments"
+  (lambda (&rest more-args)
+    (apply f (append args more-args))))

lisp/klatre/package.lisp

@@ -10,4 +10,7 @@
 
    ;; String handling
    #:+dottime-format+ #:format-dottime
-   #:try-parse-integer))
+   #:try-parse-integer
+
+   ;; Function utilities
+   #:partial))

web/panettone/src/css.lisp

@@ -64,8 +64,9 @@
     (.comment-count
      :color ,color/gray)))
 
-(defparameter comment-styles
+(defparameter issue-history-styles
-  `((.issue-comments
+  `((.issue-history
+     :list-style "none"
      :border-top "1px" "solid" ,color/gray
      :padding-top "1rem"
      :padding-left "2rem"
@@ -75,12 +76,15 @@
       :margin 0
       :padding-top "1rem")
 
-     (.comment
+     ((:or .comment .event)
       :padding-top "1rem"
       :padding-bottom "1rem"
       :border-bottom "1px" "solid" ,color/gray
 
-      (p :margin 0)))))
+      (p :margin 0))
+
+     (.event
+      :color ,color/gray))))
 
 (defparameter form-styles
   `(((:or (:and input (:or (:= type "text")
@@ -129,7 +133,7 @@
   `(,@form-styles
     ,@issue-list-styles
     ,@issue-styles
-    ,@comment-styles
+    ,@issue-history-styles
 
     (body
      :font-family "sans-serif"

web/panettone/src/model.lisp

@@ -55,6 +55,7 @@
    (body :col-type string :initarg :body :accessor body :col-default "")
    (author-dn :col-type string :initarg :author-dn :accessor author-dn)
    (comments :type list :accessor issue-comments)
+   (events :type list :accessor issue-events)
    (num-comments :type integer :accessor num-comments)
    (status :col-type issue_status
            :initarg :status
@@ -221,6 +222,22 @@ NOTE: This makes a database query, so be wary of N+1 queries"
      :where (:= 'issue-id issue-id))
     (:asc 'created-at))))
 
+(defmethod slot-unbound (cls (issue issue) (slot (eql 'events)))
+  (declare (ignore cls) (ignore slot))
+  (setf (issue-events issue) (issue-events (id issue))))
+
+(defmethod issue-events ((issue-id integer))
+  "Return a list of all events with the given ISSUE-ID, sorted oldest first.
+NOTE: This makes a database query, so be wary of N+1 queries"
+  (query-dao
+   'issue-event
+   (:order-by
+    (:select '*
+     :from 'issue-events
+     :where (:= 'issue-id issue-id))
+    (:asc 'created-at))))
+
+
 ;;;
 ;;; Writing
 ;;;

web/panettone/src/packages.lisp

@@ -24,13 +24,15 @@
   (:export
    :connect-postgres :ddl/init
 
-   :issue
+   :issue :issue-comment :issue-event
-   :issue-comment
+   :id :subject :body :author-dn :issue-id :status :created-at :acting-user-dn
-   :id :subject :body :author-dn :issue-id :status :created-at
+   :field :previous-value :new-value
 
    :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status
    :delete-issue :issue-not-found
 
+   :issue-events
+
    :issue-comments :num-comments :create-issue-comment))
 
 (defpackage panettone
@@ -38,10 +40,11 @@
         :panettone.util
         :panettone.authentication)
   (:import-from :defclass-std :defclass/std)
-  (:import-from :alexandria :if-let :when-let)
+  (:import-from :alexandria :if-let :when-let :switch)
   (:import-from
    :panettone.model
    :id :subject :body :author-dn :issue-id :status :created-at
-   :issue-comments :num-comments)
+   :field :previous-value :new-value :acting-user-dn
+   :issue-comments :num-comments :issue-events)
   (:shadow :next)
   (:export :start-pannetone :config :main))

web/panettone/src/panettone.lisp

@@ -189,6 +189,36 @@
      (:input :type "submit"
              :value "Comment"))))
 
+(defgeneric render/issue-history-item (item))
+
+(defmethod render/issue-history-item ((comment model:issue-comment))
+  (who:with-html-output (*standard-output*)
+    (who:htm
+     (:li
+      :class "comment"
+      (:p (who:esc (body comment)))
+      (:p
+       :class "comment-info"
+       (:span :class "username"
+              (who:esc (displayname (author comment)))
+              " at "
+              (who:esc (format-dottime (created-at comment)))))))))
+
+(defmethod render/issue-history-item ((event model:issue-event))
+  (when (string= (field event) "STATUS")
+    (who:with-html-output (*standard-output*)
+      (let ((user (find-user-by-dn (acting-user-dn event))))
+        (who:htm
+         (:li
+          :class "event"
+          (who:esc (displayname user))
+          (who:esc
+           (switch ((new-value event) :test #'string=)
+             ("OPEN" " reopened ")
+             ("CLOSED" " closed ")))
+          " this issue at "
+          (who:esc (format-dottime (created-at event)))))))))
+
 (defun render/issue (issue)
   (check-type issue model:issue)
   (let ((issue-id (id issue))
@@ -220,22 +250,18 @@
                                    (:open "Close")
                                    (:closed "Reopen")))))))
        (:p (who:esc (body issue)))
-       (let ((comments (issue-comments issue)))
+       (let* ((comments (issue-comments issue))
+              (events (issue-events issue))
+              (history (merge 'list
+                              comments
+                              events
+                              #'local-time:timestamp<
+                              :key #'created-at)))
          (who:htm
-          (:div
+          (:ol
-           :class "issue-comments"
+           :class "issue-history"
-           (dolist (comment comments)
+           (dolist (item history)
-             (let ((author (author comment)))
+             (render/issue-history-item item))
-               (who:htm
-                (:div
-                 :class "comment"
-                 (:p (who:esc (body comment)))
-                 (:p
-                  :class "comment-info"
-                  (:span :class "username"
-                         (who:esc (displayname author))
-                         " at "
-                         (who:esc (format-dottime (created-at comment)))))))))
            (when *user*
              (render/new-comment (id issue))))))))))
 
@@ -321,14 +347,10 @@
 (defroute show-issue
     ("/issues/:id" :decorators (@auth-optional @handle-issue-not-found))
     (&path (id 'integer))
-  (handler-case
   (let* ((issue (model:get-issue id))
          (*title* (format nil "~A | Panettone"
                           (subject issue))))
-        (render/issue issue))
+    (render/issue issue)))
-    (issue-not-found (_)
-      (declare (ignore _))
-      (render/not-found "Issue"))))
 
 (defroute handle-create-comment
     ("/issues/:id/comments"
@@ -356,7 +378,7 @@
 
 (defroute open-issue
     ("/issues/:id/open" :decorators (@auth)
-                         :method :put)
+                         :method :post)
     (&path (id 'integer))
   (model:set-issue-status id :open)
   (hunchentoot:redirect (format nil "/issues/~A" id)))