feat(web/panettone): Log when users change issue statuses
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>
This commit is contained in:
Griffin Smith
glittershark
parent
14a8142f76
commit
8e7ba41a34
7 changed files with 215 additions and 112 deletions
|
|
@ -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!)";
|
||||
};
|
||||
}
|
||||
|
|
|
|||
71
web/panettone/src/authentication.lisp
Normal file
71
web/panettone/src/authentication.lisp
Normal file
|
|
@ -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)))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,92 +1,12 @@
|
|||
(in-package :panettone)
|
||||
(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))))))
|
||||
|
||||
|
|
|
|||
13
web/panettone/test/model_test.lisp
Normal file
13
web/panettone/test/model_test.lisp
Normal file
|
|
@ -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)))))
|
||||
2
web/panettone/test/package.lisp
Normal file
2
web/panettone/test/package.lisp
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
(defpackage :panettone.tests
|
||||
(:use :cl :klatre :fiveam))
|
||||
Loading…
Reference in a new issue