b6bab664db
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>
336 lines
12 KiB
Common Lisp
336 lines
12 KiB
Common Lisp
(in-package :panettone.model)
|
|
(declaim (optimize (safety 3)))
|
|
|
|
(defun connect-postgres (&key
|
|
(host (or (uiop:getenvp "PGHOST") "localhost"))
|
|
(user (or (uiop:getenvp "PGUSER") "panettone"))
|
|
(password (or (uiop:getenvp "PGPASSWORD") "password"))
|
|
(database (or (uiop:getenvp "PGDATABASE") "panettone"))
|
|
(port (or (integer-env "PGPORT") 5432)))
|
|
"Initialize the global postgresql connection for Panettone"
|
|
(postmodern:connect-toplevel database user password host :port port))
|
|
|
|
;;;
|
|
;;; Schema
|
|
;;;
|
|
|
|
(define-constant +issue-statuses+ '(:open :closed)
|
|
:test #'equal)
|
|
|
|
(deftype issue-status ()
|
|
"Type specifier for the status of an `issue'"
|
|
(cons 'member +issue-statuses+))
|
|
|
|
(defun ddl/create-issue-status ()
|
|
"Issue DDL to create the `issue-status' type, if it doesn't exist"
|
|
(unless (query (:select (:exists (:select 1
|
|
:from 'pg_type
|
|
:where (:= 'typname "issue_status"))))
|
|
:single)
|
|
(query (sql-compile
|
|
`(:create-enum issue-status ,+issue-statuses+)))))
|
|
|
|
(defclass has-created-at ()
|
|
((created-at :col-type timestamp
|
|
:col-default (local-time:now)
|
|
:initarg :created-at
|
|
:accessor created-at))
|
|
(:metaclass dao-class))
|
|
|
|
(defun created-at->timestamp (object)
|
|
(assert (slot-exists-p object 'created-at))
|
|
(unless (or (not (slot-boundp object 'created-at))
|
|
(typep (slot-value object 'created-at) 'local-time:timestamp))
|
|
(setf (slot-value object 'created-at)
|
|
(local-time:universal-to-timestamp (created-at object)))))
|
|
|
|
(defmethod initialize-instance :after
|
|
((obj has-created-at) &rest initargs &key &allow-other-keys)
|
|
(declare (ignore initargs))
|
|
(created-at->timestamp obj))
|
|
|
|
(defclass issue (has-created-at)
|
|
((id :col-type serial :initarg :id :accessor id)
|
|
(subject :col-type string :initarg :subject :accessor subject)
|
|
(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
|
|
:accessor status
|
|
:initform :open
|
|
:col-default "open"))
|
|
(:metaclass dao-class)
|
|
(:keys id)
|
|
(:table-name issues)
|
|
(:documentation
|
|
"Issues are the primary entity in the Panettone database. An issue is
|
|
reported by a user, has a subject and an optional body, and can be either
|
|
open or closed"))
|
|
|
|
(defmethod cl-postgres:to-sql-string ((kw (eql :open)))
|
|
(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)
|
|
(declare (ignore initargs))
|
|
(unless (symbolp (status issue))
|
|
(setf (status issue)
|
|
(intern (string-upcase (status issue))
|
|
"KEYWORD"))))
|
|
|
|
(deftable issue (!dao-def))
|
|
|
|
(defclass issue-comment (has-created-at)
|
|
((id :col-type integer :col-identity t :initarg :id :accessor id)
|
|
(body :col-type string :initarg :body :accessor body)
|
|
(author-dn :col-type string :initarg :author-dn :accessor author-dn)
|
|
(issue-id :col-type integer :initarg :issue-id :accessor :user-id))
|
|
(:metaclass dao-class)
|
|
(:keys id)
|
|
(:table-name issue_comments)
|
|
(:documentation "Comments on an `issue'"))
|
|
(deftable (issue-comment "issue_comments")
|
|
(!dao-def)
|
|
(!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade))
|
|
|
|
(defclass issue-event (has-created-at)
|
|
((id :col-type integer :col-identity t :initarg :id :accessor id)
|
|
(issue-id :col-type integer
|
|
:initarg :issue-id
|
|
:accessor issue-id)
|
|
(acting-user-dn :col-type string
|
|
:initarg :acting-user-dn
|
|
:accessor acting-user-dn)
|
|
(field :col-type (or string db-null)
|
|
:initarg :field
|
|
:accessor field)
|
|
(previous-value :col-type (or string db-null)
|
|
:initarg :previous-value
|
|
:accessor previous-value)
|
|
(new-value :col-type (or string db-null)
|
|
:initarg :new-value
|
|
:accessor new-value))
|
|
(:metaclass dao-class)
|
|
(:keys id)
|
|
(:table-name issue_events)
|
|
(:documentation "Events that have occurred for an issue.
|
|
|
|
If a field has been changed on an issue, the SYMBOL-NAME of that slot will be in
|
|
FIELD, its previous value will be formatted using ~A into PREVIOUS-VALUE, and
|
|
its new value will be formatted using ~A into NEW-VALUE"))
|
|
|
|
(deftable (issue-event "issue_events")
|
|
(!dao-def)
|
|
(!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade))
|
|
|
|
(define-constant +all-tables+
|
|
'(issue
|
|
issue-comment
|
|
issue-event)
|
|
:test #'equal)
|
|
|
|
(defun ddl/create-tables ()
|
|
"Issue DDL to create all tables, if they don't already exist."
|
|
(dolist (table +all-tables+)
|
|
(unless (table-exists-p (dao-table-name table))
|
|
(create-table table))))
|
|
|
|
(defun ddl/init ()
|
|
"Idempotently initialize the full database schema for Panettone"
|
|
(ddl/create-issue-status)
|
|
(ddl/create-tables))
|
|
|
|
;;;
|
|
;;; Querying
|
|
;;;
|
|
|
|
(define-condition issue-not-found (error)
|
|
((id :type integer
|
|
:initarg :id
|
|
:reader not-found-id
|
|
:documentation "ID of the issue that was not found"))
|
|
(:documentation
|
|
"Error condition for when an issue requested by ID is not found"))
|
|
|
|
(defun get-issue (id)
|
|
"Look up the 'issue with the given ID and return it, or signal a condition of
|
|
type `ISSUE-NOT-FOUND'."
|
|
(restart-case
|
|
(or (get-dao 'issue id)
|
|
(error 'issue-not-found :id id))
|
|
(different-id (new-id)
|
|
:report "Use a different issue ID"
|
|
:interactive (lambda ()
|
|
(format t "Enter a new ID: ")
|
|
(multiple-value-list (eval (read))))
|
|
(get-issue new-id))))
|
|
|
|
(defun issue-exists-p (id)
|
|
"Returns `T' if an issue with the given ID exists"
|
|
(query
|
|
(:select (:exists (:select 1
|
|
:from 'issues
|
|
:where (:= 'id id))))
|
|
:single))
|
|
|
|
(defun list-issues (&key status (with '(:num-comments)))
|
|
"Return a list of all issues with the given STATUS (or all if nil), ordered by
|
|
ID descending. If WITH contains `:NUM-COMMENTS' (the default) each issue will
|
|
have the `num-comments' slot filled with the number of comments on that issue
|
|
(to avoid N+1 queries)."
|
|
(let* ((condition (unless (null status)
|
|
`(:where (:= status $1))))
|
|
(select (if (find :num-comments with)
|
|
`(:select issues.* (:as (:count issue-comments.id)
|
|
num-comments)
|
|
:from issues
|
|
:left-join issue-comments
|
|
:on (:= issues.id issue-comments.issue-id)
|
|
,@condition
|
|
:group-by issues.id)
|
|
`(:select * :from issues ,@condition)))
|
|
(query (sql-compile
|
|
`(:order-by ,select (:desc id)))))
|
|
(with-column-writers ('num_comments 'num-comments)
|
|
(query-dao 'issue query status))))
|
|
|
|
(defmethod num-comments ((issue-id integer))
|
|
"Return the number of comments for the given ISSUE-ID."
|
|
(query
|
|
(:select (:count '*)
|
|
:from 'issue-comments
|
|
:where (:= 'issue-id issue-id))
|
|
:single))
|
|
|
|
(defmethod slot-unbound (cls (issue issue) (slot (eql 'comments)))
|
|
(declare (ignore cls) (ignore slot))
|
|
(setf (issue-comments issue) (issue-comments (id issue))))
|
|
|
|
(defmethod issue-comments ((issue-id integer))
|
|
"Return a list of all comments with the given ISSUE-ID, sorted oldest first.
|
|
NOTE: This makes a database query, so be wary of N+1 queries"
|
|
(query-dao
|
|
'issue-comment
|
|
(:order-by
|
|
(:select '*
|
|
:from 'issue-comments
|
|
: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
|
|
;;;
|
|
|
|
(defun record-issue-event
|
|
(issue-id &key
|
|
field
|
|
previous-value
|
|
new-value)
|
|
"Record in the database that the user identified by `AUTHN:*USER*' updated
|
|
ISSUE-ID, and return the resulting `ISSUE-EVENT'. If no user is currently
|
|
authenticated, warn and no-op"
|
|
(check-type issue-id (integer))
|
|
(check-type field (or null symbol))
|
|
(if authn:*user*
|
|
(insert-dao
|
|
(make-instance 'issue-event
|
|
:issue-id issue-id
|
|
:acting-user-dn (authn:dn authn:*user*)
|
|
:field (symbol-name field)
|
|
:previous-value (when previous-value
|
|
(format nil "~A" previous-value))
|
|
:new-value (when new-value
|
|
(format nil "~A" new-value))))
|
|
(warn "Performing operation as unauthenticated user")))
|
|
|
|
(defun create-issue (&rest attrs)
|
|
"Insert a new issue into the database with the given ATTRS, which should be
|
|
a plist of initforms, and return an instance of `issue'"
|
|
(insert-dao (apply #'make-instance 'issue attrs)))
|
|
|
|
(defun delete-issue (issue)
|
|
(delete-dao issue))
|
|
|
|
(defun set-issue-status (issue-id status)
|
|
"Set the status of the issue with the given ISSUE-ID to STATUS in the db. If
|
|
the issue doesn't exist, signals `issue-not-found'"
|
|
(check-type issue-id integer)
|
|
(check-type status issue-status)
|
|
(let ((original-status (query (:select 'status
|
|
:from 'issues
|
|
:where (:= 'id issue-id))
|
|
:single)))
|
|
(when (zerop (execute (:update 'issues
|
|
:set 'status (cl-postgres:to-sql-string status)
|
|
:where (:= 'id issue-id))))
|
|
(error 'issue-not-found :id issue-id))
|
|
(record-issue-event
|
|
issue-id
|
|
:field 'status
|
|
:previous-value (string-upcase original-status)
|
|
: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
|
|
`issue-comment'. If no issue exists with `ID' ISSUE-ID, signals
|
|
`issue-not-found'."
|
|
(unless (issue-exists-p issue-id)
|
|
(error 'issue-not-found :id issue-id))
|
|
(insert-dao (apply #'make-instance 'issue-comment :issue-id issue-id attrs)))
|
|
|
|
(comment
|
|
(connect-postgres)
|
|
(ddl/init)
|
|
(make-instance 'issue :subject "test")
|
|
(create-issue :subject "test"
|
|
:author-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
|
|
)
|