mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(web/panettone): Allow editing issues

Browse source 
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>
This commit is contained in:
Griffin Smith 2020-08-01 12:10:27 -04:00 committed by glittershark
parent 2646e57aae
commit b6bab664db
4 changed files with 146 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
web/panettone/src/css.lisp
View file

@ -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))))

26
web/panettone/src/model.lisp
View file

@ -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

6
web/panettone/src/packages.lisp
View file

@ -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

105
web/panettone/src/panettone.lisp
View file

@ -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")
(who:with-html-output (*standard-output*)
(let ((user (find-user-by-dn (acting-user-dn event))))
(who:htm
(who:with-html-output (*standard-output*)
(: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 at "
(who:esc (format-dottime (created-at event)))))))))
" 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"
(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 :type "submit"
:class (case issue-status
:input-class (case issue-status
(:open "close-issue")
(:closed "open-issue"))
:value (case issue-status
:label (case issue-status
(:open "Close")
(:closed "Reopen")))))))
(:closed "Reopen"))))))
(:p (who:str (render-markdown (body issue))))
(let* ((comments (issue-comments issue))
(events (issue-events issue))
@ -388,13 +427,15 @@
(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
@ -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)