diff options
Diffstat (limited to 'web/panettone')
| -rw-r--r-- | web/panettone/src/css.lisp | 16 | ||||
| -rw-r--r-- | web/panettone/src/model.lisp | 26 | ||||
| -rw-r--r-- | web/panettone/src/packages.lisp | 6 | ||||
| -rw-r--r-- | web/panettone/src/panettone.lisp | 139 |
4 files changed, 146 insertions, 41 deletions
diff --git a/web/panettone/src/css.lisp b/web/panettone/src/css.lisp index fe6cad66b122..0192b816ea1c 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 1ea0214f512a..300ee19b6b10 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 16cb39dec504..596589f7907c 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 4f704ebc2430..dc3a1cc29547 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))) |