feat(web/panettone): Allow editing issues r/1539

Allow editing both the subject and the body of issues, recording events
indicating the edit and displaying those events in the issue history.

Fixes: #14
Change-Id: I9ed05271ce9bf6bda4e56f15e249c0f28c862b27
Reviewed-on: https://cl.tvl.fyi/c/depot/+/1517
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>

4 files changed, 146 insertions, 41 deletions

diff --git a/web/panettone/src/css.lisp b/web/panettone/src/css.lisp
index fe6cad66b1..0192b816ea 100644
--- a/web/panettone/src/css.lisp
+++ b/web/panettone/src/css.lisp
@@ -4,6 +4,9 @@
 (defparameter color/black
   "rgb(24, 24, 24)")
 
+(defparameter color/light-gray
+  "#EEE")
+
 (defparameter color/gray
   "#8D8D8D")
 
@@ -105,7 +108,8 @@
     ((:and input (:= type "submit"))
      :-webkit-appearance "none"
      :border "none"
-     :cursor "pointer")
+     :cursor "pointer"
+     :font-size "1rem")
 
     ,@(button '(:and input (:= type "submit")))
 
@@ -126,6 +130,16 @@
      :justify-content "space-between"
      :align-items "center"
 
+     ,@(button '.edit-issue)
+
+     (.created-by-at
+      :flex 1)
+
+     (.edit-issue
+      :background-color ,color/light-gray
+      :flex 0
+      :margin-right "0.5rem")
+
      (.close-issue
       :background-color ,color/failure))))
 
diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp
index 1ea0214f51..300ee19b6b 100644
--- a/web/panettone/src/model.lisp
+++ b/web/panettone/src/model.lisp
@@ -74,6 +74,9 @@
   (cl-postgres:to-sql-string "open"))
 (defmethod cl-postgres:to-sql-string ((kw (eql :closed)))
   (cl-postgres:to-sql-string "closed"))
+(defmethod cl-postgres:to-sql-string ((ts local-time:timestamp))
+  (cl-postgres:to-sql-string
+   (local-time:timestamp-to-unix ts)))
 
 (defmethod initialize-instance :after
     ((issue issue) &rest initargs &key &allow-other-keys)
@@ -292,6 +295,29 @@ the issue doesn't exist, signals `issue-not-found'"
      :new-value status)
     (values)))
 
+(defun update-issue (issue &rest attrs)
+  "Update the fields of ISSUE with the given ATTRS, which is a plist of slot and
+value, and record events for the updates"
+  (let ((set-fields
+          (iter (for slot in '(subject body))
+            (for new-value = (getf attrs slot))
+            (appending
+             (let ((previous-value (slot-value issue slot)))
+               (when (and new-value (not (equalp
+                                          new-value
+                                          previous-value)))
+                 (record-issue-event (id issue)
+                                     :field slot
+                                     :previous-value previous-value
+                                     :new-value new-value)
+                 (setf (slot-value issue slot) new-value)
+                 (list slot new-value)))))))
+    (execute
+     (sql-compile
+      `(:update issues
+        :set ,@set-fields
+        :where (:= id ,(id issue)))))))
+
 (defun create-issue-comment (&rest attrs &key issue-id &allow-other-keys)
   "Insert a new issue comment into the database with the given ATTRS and
 ISSUE-ID, which should be a plist of initforms, and return an instance of
diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp
index 16cb39dec5..596589f790 100644
--- a/web/panettone/src/packages.lisp
+++ b/web/panettone/src/packages.lisp
@@ -19,8 +19,8 @@
 
 (defpackage panettone.model
   (:nicknames :model)
-  (:use :cl :panettone.util :klatre :postmodern)
-  (:import-from :alexandria :if-let :define-constant)
+  (:use :cl :panettone.util :klatre :postmodern :iterate)
+  (:import-from :alexandria :if-let :when-let :define-constant)
   (:export
    :connect-postgres :ddl/init
 
@@ -29,7 +29,7 @@
    :field :previous-value :new-value
 
    :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status
-   :delete-issue :issue-not-found
+   :update-issue :delete-issue :issue-not-found
 
    :issue-events
 
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
index 4f704ebc24..dc3a1cc295 100644
--- a/web/panettone/src/panettone.lisp
+++ b/web/panettone/src/panettone.lisp
@@ -107,6 +107,20 @@
         (when ,footer
           (render/footer-nav)))))))
 
+(defun form-button (&key
+                      class
+                      input-class
+                      href
+                      label
+                      (method "post"))
+  (who:with-html-output (*standard-output*)
+    (:form :class class
+           :method method
+           :action href
+           (:input :type "submit"
+                   :class input-class
+                   :value label))))
+
 (defun render/alert (message)
   "Render an alert box for MESSAGE, if non-null"
   (check-type message (or null string))
@@ -209,28 +223,38 @@
       (:a :href "/" "View open isues"))
      (render/issue-list :issues issues))))
 
-(defun render/new-issue (&optional message)
+(defun render/issue-form (&optional issue message)
   (render ()
     (:header
-     (:h1 "New Issue"))
+     (:h1
+      (who:esc
+       (if (id issue) "Edit Issue" "New Issue"))))
     (:main
      (render/alert message)
      (:form :method "post"
-            :action "/issues"
+            :action (if (id issue)
+                        (format nil "/issues/~A"
+                                (id issue))
+                        "/issues")
             :class "issue-form"
             (:div
              (:input :type "text"
                      :id "subject"
                      :name "subject"
-                     :placeholder "Subject"))
+                     :placeholder "Subject"
+                     :value (subject issue)))
 
             (:div
              (:textarea :name "body"
                         :placeholder "Description"
-                        :rows 10))
+                        :rows 10
+                        (who:esc (body issue))))
 
             (:input :type "submit"
-                    :value "Create Issue")))))
+                    :value
+                    (if (id issue)
+                        "Save Issue"
+                        "Create Issue"))))))
 
 (defun render/new-comment (issue-id)
   (who:with-html-output (*standard-output*)
@@ -261,19 +285,28 @@
               (who:esc (format-dottime (created-at comment)))))))))
 
 (defmethod render/issue-history-item ((event model:issue-event))
-  (when (string= (field event) "STATUS")
+  (let ((user (find-user-by-dn (acting-user-dn event))))
     (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)))))))))
+      (:li
+       :class "event"
+       (who:esc (displayname user))
+       (if (string= (field event) "STATUS")
+           (who:htm
+            (who:esc
+             (switch ((new-value event) :test #'string=)
+               ("OPEN" " reopened ")
+               ("CLOSED" " closed ")))
+            " this issue ")
+           (who:htm
+            " changed the "
+            (who:esc (string-downcase (field event)))
+            " of this issue from \""
+            (who:esc (previous-value event))
+            "\" to \""
+            (who:esc (new-value event))
+            "\""))
+       " at "
+       (who:esc (format-dottime (created-at event)))))))
 
 (defun render/issue (issue)
   (check-type issue model:issue)
@@ -291,20 +324,26 @@
 
         (when *user*
           (who:htm
-           (:form :class "set-issue-status"
-                  :method "post"
-                  :action (format nil "/issues/~A/~A"
-                                  issue-id
-                                  (case issue-status
-                                    (:open "close")
-                                    (:closed "open")))
-                  (:input :type "submit"
-                          :class (case issue-status
-                                   (:open "close-issue")
-                                   (:closed "open-issue"))
-                          :value (case issue-status
-                                   (:open "Close")
-                                   (:closed "Reopen")))))))
+           (when (string= (author-dn issue)
+                          (dn *user*))
+             (who:htm
+              (:a :class "edit-issue"
+                  :href (format nil "/issues/~A/edit"
+                                issue-id)
+                  "Edit")))
+           (form-button
+            :class "set-issue-status"
+            :href (format nil "/issues/~A/~A"
+                          issue-id
+                          (case issue-status
+                            (:open "close")
+                            (:closed "open")))
+            :input-class (case issue-status
+                           (:open "close-issue")
+                           (:closed "open-issue"))
+            :label (case issue-status
+                     (:open "Close")
+                     (:closed "Reopen"))))))
        (:p (who:str (render-markdown (body issue))))
        (let* ((comments (issue-comments issue))
               (events (issue-events issue))
@@ -388,17 +427,19 @@
     (render/closed-issues :issues issues)))
 
 (defroute new-issue ("/issues/new" :decorators (@auth)) ()
-  (render/new-issue))
+  (render/issue-form))
 
 (defroute handle-create-issue
     ("/issues" :method :post :decorators (@auth @txn))
     (&post subject body)
   (if (string= subject "")
-      (render/new-issue "Subject is required")
+      (render/issue-form
+       (make-instance 'model:issue :subject subject :body body)
+       "Subject is required")
       (progn
         (model:create-issue :subject subject
-                                      :body body
-                                      :author-dn (dn *user*))
+                            :body body
+                            :author-dn (dn *user*))
         (hunchentoot:redirect "/"))))
 
 (defroute show-issue
@@ -409,6 +450,30 @@
                           (subject issue))))
     (render/issue issue)))
 
+(defroute edit-issue
+    ("/issues/:id/edit" :decorators (@auth @handle-issue-not-found))
+    (&path (id 'integer))
+  (let* ((issue (model:get-issue id))
+         (*title* "Edit Issue | Panettone"))
+    (render/issue-form issue)))
+
+(defroute update-issue
+    ("/issues/:id" :decorators (@auth @handle-issue-not-found @txn)
+                   ;; NOTE: this should be a put, but we're all HTML forms
+                   ;; right now and those don't support PUT
+                   :method :post)
+    (&path (id 'integer) &post subject body)
+  (let ((issue (model:get-issue id)))
+    ;; only the original author can edit an issue
+    (if (string-equal (author-dn issue)
+                      (dn *user*))
+        (progn
+          (model:update-issue issue
+                              'model:subject subject
+                              'model:body body)
+          (hunchentoot:redirect (format nil "/issues/~A" id)))
+        (render/not-found "Issue"))))
+
 (defroute handle-create-comment
     ("/issues/:id/comments"
      :decorators (@auth @handle-issue-not-found @txn)
@@ -435,7 +500,7 @@
 
 (defroute open-issue
     ("/issues/:id/open" :decorators (@auth)
-                         :method :post)
+                        :method :post)
     (&path (id 'integer))
   (model:set-issue-status id :open)
   (hunchentoot:redirect (format nil "/issues/~A" id)))