diff options
Diffstat (limited to 'web/panettone/src/model.lisp')
| -rw-r--r-- | web/panettone/src/model.lisp | 421 |
1 files changed, 421 insertions, 0 deletions
diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp new file mode 100644 index 000000000000..4fa51026a086 --- /dev/null +++ b/web/panettone/src/model.lisp @@ -0,0 +1,421 @@ +(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)) + +(defun make-thread + (function &rest args) + "Make a new thread as per `BORDEAUX-THREADS:MAKE-THREAD' but with its own, new +database connection." + (let ((spec `(,(or (uiop:getenvp "PGDATABASE") "panettone") + ,(or (uiop:getenvp "PGUSER") "panettone") + ,(or (uiop:getenvp "PGPASSWORD") "password") + ,(or (uiop:getenvp "PGHOST") "localhost") + :port ,(or (integer-env "PGPORT") 5432)))) + (apply #'bt:make-thread + (lambda () + (postmodern:call-with-connection spec function)) + args))) + +;;; +;;; Schema +;;; + +(defclass user-settings () + ((user-dn :col-type string :initarg :user-dn :accessor user-dn) + (enable-email-notifications + :col-type boolean + :initarg :enable-email-notifications + :accessor enable-email-notifications-p + :initform t + :col-default t)) + (:metaclass dao-class) + (:keys user-dn) + (:table-name user_settings) + (:documentation + "Panettone settings for an individual user DN")) + +(deftable (user-settings "user_settings") + (!dao-def)) + +(defun settings-for-user (dn) + "Retrieve the settings for the user with the given DN, creating a new row in + the database if not yet present" + (or + (car + (query-dao + 'user-settings + (:select '* :from 'user-settings :where (:= 'user-dn dn)))) + (insert-dao (make-instance 'user-settings :user-dn dn)))) + +(defun update-user-settings (settings &rest attrs) + "Update the fields of the settings for USER with the given ATTRS, which is a + plist of slot and value" + (check-type settings user-settings) + (when-let ((set-fields + (iter + (for slot in '(enable-email-notifications)) + (for new-value = (getf attrs slot)) + (appending + (progn + (setf (slot-value settings slot) new-value) + (list slot new-value)))))) + (execute + (sql-compile + `(:update user-settings + :set ,@set-fields + :where (:= user-dn ,(user-dn settings))))))) + + +(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 + user-settings) + :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))) + +(defun issue-commenter-dns (issue-id) + "Returns a list of all the dns of users who have commented on ISSUE-ID" + (query (:select 'author-dn :distinct + :from 'issue-comments + :where (:= 'issue-id issue-id)) + :column)) + +(defun issue-subscribers (issue-id) + "Returns a list of user DNs who should receive notifications for actions taken + on ISSUE-ID. + +Currently this is implemented as the author of issue plus all the users who have +commented on the issue, but in the future we likely want to also allow +explicitly subscribing to / unsubscribing from individual issues." + (let ((issue (get-issue issue-id))) + (adjoin (author-dn issue) + (issue-commenter-dns issue-id) + :test #'equal))) + + +(comment + (connect-postgres) + (ddl/init) + (make-instance 'issue :subject "test") + (create-issue :subject "test" + :author-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi") + + (issue-commenter-dns 1) + (issue-subscribers 1) + + ) |