feat(web/panettone): Log when users change issue statuses r/1509

Log in the database, in a way that will generalize to tracking edit
history as well, when users change the status of an issue. To facilitate
easily knowing who is currently authenticated (without introducing a
circular dependency) the authentication-relaated code has also been
factored out into its own package, which is nice because we want to
replace that sooner rather than later anyway.

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

7 files changed, 215 insertions, 112 deletions

diff --git a/web/panettone/default.nix b/web/panettone/default.nix
index 637ccfea9d..4d40209231 100644
--- a/web/panettone/default.nix
+++ b/web/panettone/default.nix
@@ -22,7 +22,21 @@ depot.nix.buildLisp.program {
     ./src/packages.lisp
     ./src/util.lisp
     ./src/css.lisp
+    ./src/authentication.lisp
     ./src/model.lisp
     ./src/panettone.lisp
   ];
+
+  tests = {
+    deps = with depot.third_party.lisp; [
+      fiveam
+    ];
+
+    srcs = [
+      ./test/package.lisp
+      ./test/model_test.lisp
+    ];
+
+    expression = "(fiveam:run!)";
+  };
 }
diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp
new file mode 100644
index 0000000000..e4f893f883
--- /dev/null
+++ b/web/panettone/src/authentication.lisp
@@ -0,0 +1,71 @@
+(in-package :panettone.authentication)
+
+(defvar *user* nil
+  "The currently logged-in user")
+
+(defvar *ldap* nil
+  "The ldap connection")
+
+(defclass/std user ()
+  ((cn dn mail displayname :type string)))
+
+(defun connect-ldap (&key
+                       (host "localhost")
+                       (port 389))
+  (setq *ldap* (ldap:new-ldap :host host :port port)))
+
+(defun ldap-entry->user (entry)
+  (apply
+   #'make-instance
+   'user
+   :dn (ldap:dn entry)
+   (alexandria:mappend
+    (lambda (field)
+      (list field (car (ldap:attr-value entry field))))
+    (list :mail
+          :cn
+          :displayname))))
+
+(defun find-user/ldap (username)
+  (check-type username (simple-array character (*)))
+  (ldap:search
+   *ldap*
+   `(and (= objectClass organizationalPerson)
+         (or
+          (= cn ,username)
+          (= dn ,username)))
+   ;; TODO(grfn): make this configurable
+   :base "ou=users,dc=tvl,dc=fyi")
+  (ldap:next-search-result *ldap*))
+
+(defun find-user (username)
+  (check-type username (simple-array character (*)))
+  (when-let ((ldap-entry (find-user/ldap username)))
+    (ldap-entry->user ldap-entry)))
+
+(defun find-user-by-dn (dn)
+  (ldap:search *ldap* `(= objectClass organizationalPerson)
+               :base dn
+               :scope 'ldap:base)
+  (when-let ((ldap-entry (ldap:next-search-result *ldap*)))
+    (ldap-entry->user ldap-entry)))
+
+(comment
+ (user-by-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
+ )
+
+(defun authenticate-user (user-or-username password)
+  "Checks the given USER-OR-USERNAME has the given PASSWORD, by making a bind
+request against the ldap server at *ldap*. Returns the user if authentication is
+successful, `nil' otherwise"
+  (when-let ((user (if (typep user-or-username 'user) user-or-username
+                       (find-user user-or-username))))
+    (let ((dn (dn user)))
+      (let ((code-sym
+              (nth-value 1 (ldap:bind
+                            (ldap:new-ldap :host (ldap:host *ldap*)
+                                           :port (ldap:port *ldap*)
+                                           :user dn
+                                           :pass password)))))
+        (when (equalp code-sym 'trivial-ldap:success)
+          user)))))
diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp
index 3b19901c99..0f14cede4e 100644
--- a/web/panettone/src/model.lisp
+++ b/web/panettone/src/model.lisp
@@ -30,7 +30,26 @@
     (query (sql-compile
             `(:create-enum issue-status ,+issue-statuses+)))))
 
-(defclass issue ()
+(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 "")
@@ -41,10 +60,7 @@
            :initarg :status
            :accessor status
            :initform :open
-           :col-default "open")
-   (created-at :col-type timestamp
-               :col-default (local-time:now)
-               :accessor created-at))
+           :col-default "open"))
   (:metaclass dao-class)
   (:keys id)
   (:table-name issues)
@@ -58,32 +74,21 @@
 (defmethod cl-postgres:to-sql-string ((kw (eql :closed)))
   (cl-postgres:to-sql-string "closed"))
 
-(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
     ((issue issue) &rest initargs &key &allow-other-keys)
   (declare (ignore initargs))
   (unless (symbolp (status issue))
     (setf (status issue)
           (intern (string-upcase (status issue))
-                  "KEYWORD")))
-  (created-at->timestamp issue))
+                  "KEYWORD"))))
 
 (deftable issue (!dao-def))
 
-(defclass issue-comment ()
+(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)
-   (created-at :col-type timestamp
-               :col-default (local-time:now)
-               :accessor created-at))
+   (issue-id :col-type integer :initarg :issue-id :accessor :user-id))
   (:metaclass dao-class)
   (:keys id)
   (:table-name issue_comments)
@@ -92,19 +97,50 @@
   (!dao-def)
   (!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade))
 
-(defmethod initialize-instance :after
-    ((issue-comment issue-comment) &rest initargs &key &allow-other-keys)
-  (declare (ignore initargs))
-  (created-at->timestamp issue-comment))
+(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 '(issue issue-comment))
+  (dolist (table +all-tables+)
     (unless (table-exists-p (dao-table-name table))
       (create-table table))))
 
 (defun ddl/init ()
-  "Idempotently nitialize the full database schema for Panettone"
+  "Idempotently initialize the full database schema for Panettone"
   (ddl/create-issue-status)
   (ddl/create-tables))
 
@@ -189,6 +225,28 @@ NOTE: This makes a database query, so be wary of N+1 queries"
 ;;; 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'"
@@ -202,10 +260,20 @@ a plist of initforms, and return an instance of `issue'"
 the issue doesn't exist, signals `issue-not-found'"
   (check-type issue-id integer)
   (check-type status issue-status)
-  (when (zerop (execute (:update 'issues
-                         :set 'status (cl-postgres:to-sql-string status)
-                         :where (:= 'id issue-id))))
-    (error 'issue-not-found :id issue-id)))
+  (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 create-issue-comment (&rest attrs &key issue-id &allow-other-keys)
   "Insert a new issue comment into the database with the given ATTRS and
diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp
index 48db18de3d..c5dd6aa5ae 100644
--- a/web/panettone/src/packages.lisp
+++ b/web/panettone/src/packages.lisp
@@ -7,6 +7,16 @@
   (:use :cl :lass)
   (:export :styles))
 
+(defpackage :panettone.authentication
+  (:nicknames :authn)
+  (:use :cl :panettone.util :klatre)
+  (:import-from :defclass-std :defclass/std)
+  (:import-from :alexandria :when-let)
+  (:export
+   :*user* :*ldap*
+   :user :cn :dn :mail :displayname
+   :connect-ldap :find-user :find-user-by-dn :authenticate-user))
+
 (defpackage panettone.model
   (:nicknames :model)
   (:use :cl :panettone.util :klatre :postmodern)
@@ -19,12 +29,14 @@
    :id :subject :body :author-dn :issue-id :status :created-at
 
    :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status
-   :delete-issue
+   :delete-issue :issue-not-found
 
    :issue-comments :num-comments :create-issue-comment))
 
 (defpackage panettone
-  (:use :cl :panettone.util :klatre :easy-routes :iterate)
+  (:use :cl :klatre :easy-routes :iterate
+        :panettone.util
+        :panettone.authentication)
   (:import-from :defclass-std :defclass/std)
   (:import-from :alexandria :if-let :when-let)
   (:import-from
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
index 15d3ba7577..4dc00db239 100644
--- a/web/panettone/src/panettone.lisp
+++ b/web/panettone/src/panettone.lisp
@@ -2,91 +2,11 @@
 (declaim (optimize (safety 3)))
 
 ;;;
-;;; Data model
-;;;
-
-(defclass/std user ()
-  ((cn dn mail displayname :type string)))
-
-;;;
-;;; LDAP integration
-;;;
-
-(defvar *ldap* nil
-  "The ldap connection")
-
-(defun connect-ldap (&key
-                       (host "localhost")
-                       (port 389))
-  (setq *ldap* (ldap:new-ldap :host host :port port)))
-
-(defun ldap-entry->user (entry)
-  (apply
-   #'make-instance
-   'user
-   :dn (ldap:dn entry)
-   (alexandria:mappend
-    (lambda (field)
-      (list field (car (ldap:attr-value entry field))))
-    (list :mail
-          :cn
-          :displayname))))
-
-(defun find-user/ldap (username)
-  (check-type username (simple-array character (*)))
-  (ldap:search
-   *ldap*
-   `(and (= objectClass organizationalPerson)
-         (or
-          (= cn ,username)
-          (= dn ,username)))
-   ;; TODO(grfn): make this configurable
-   :base "ou=users,dc=tvl,dc=fyi")
-  (ldap:next-search-result *ldap*))
-
-(defun find-user (username)
-  (check-type username (simple-array character (*)))
-  (when-let ((ldap-entry (find-user/ldap username)))
-    (ldap-entry->user ldap-entry)))
-
-(defun find-user-by-dn (dn)
-  (ldap:search *ldap* `(= objectClass organizationalPerson)
-               :base dn
-               :scope 'ldap:base)
-  (when-let ((ldap-entry (ldap:next-search-result *ldap*)))
-    (ldap-entry->user ldap-entry)))
-
-(comment
- (user-by-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
- )
-
-(defun authenticate-user (user-or-username password)
-  "Checks the given USER-OR-USERNAME has the given PASSWORD, by making a bind
-request against the ldap server at *ldap*. Returns the user if authentication is
-successful, `nil' otherwise"
-  (when-let ((user (if (typep user-or-username 'user) user-or-username
-                       (find-user user-or-username))))
-    (let ((dn (dn user)))
-      (let ((code-sym
-              (nth-value 1 (ldap:bind
-                            (ldap:new-ldap :host (ldap:host *ldap*)
-                                           :port (ldap:port *ldap*)
-                                           :user dn
-                                           :pass password)))))
-        (when (equalp code-sym 'trivial-ldap:success)
-          user)))))
-
-(defun author (object)
-  (find-user-by-dn (author-dn object)))
-
-;;;
 ;;; Views
 ;;;
 
 (defvar *title* "Panettone")
 
-(defvar *user* nil)
-
 (setf (who:html-mode) :html5)
 
 (defun render/footer-nav ()
@@ -112,6 +32,9 @@ successful, `nil' otherwise"
                                           :utf-8))
                "Log In")))))))
 
+(defun author (object)
+  (find-user-by-dn (author-dn object)))
+
 (defmacro render ((&key (footer t)) &body body)
   `(who:with-html-output-to-string (*standard-output* nil :prologue t)
      (:html
@@ -349,7 +272,7 @@ successful, `nil' otherwise"
 
 (defun @handle-issue-not-found (next)
   (handler-case (funcall next)
-    (issue-not-found (err)
+    (model:issue-not-found (err)
       (render/not-found
        (format nil "Issue #~A" (model:id err))))))
 
diff --git a/web/panettone/test/model_test.lisp b/web/panettone/test/model_test.lisp
new file mode 100644
index 0000000000..e4cd78a65a
--- /dev/null
+++ b/web/panettone/test/model_test.lisp
@@ -0,0 +1,13 @@
+(in-package :panettone.tests)
+(declaim (optimize (safety 3)))
+
+(test initialize-issue-status-test
+  (let ((issue (make-instance 'model:issue :status "open")))
+    (is (eq :open (model:status issue)))))
+
+(test initialize-issue-created-at-test
+  (let* ((time (get-universal-time))
+         (issue (make-instance 'model:issue :created-at time)))
+    (is (local-time:timestamp=
+         (local-time:universal-to-timestamp time)
+         (model:created-at issue)))))
diff --git a/web/panettone/test/package.lisp b/web/panettone/test/package.lisp
new file mode 100644
index 0000000000..77ba1b00bb
--- /dev/null
+++ b/web/panettone/test/package.lisp
@@ -0,0 +1,2 @@
+(defpackage :panettone.tests
+  (:use :cl :klatre :fiveam))