diff options
Diffstat (limited to 'web/panettone')
| -rw-r--r-- | web/panettone/default.nix | 14 | ||||
| -rw-r--r-- | web/panettone/src/authentication.lisp | 71 | ||||
| -rw-r--r-- | web/panettone/src/model.lisp | 126 | ||||
| -rw-r--r-- | web/panettone/src/packages.lisp | 16 | ||||
| -rw-r--r-- | web/panettone/src/panettone.lisp | 85 | ||||
| -rw-r--r-- | web/panettone/test/model_test.lisp | 13 | ||||
| -rw-r--r-- | web/panettone/test/package.lisp | 2 |
7 files changed, 215 insertions, 112 deletions
diff --git a/web/panettone/default.nix b/web/panettone/default.nix index 637ccfea9d00..4d4020923174 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 000000000000..e4f893f88330 --- /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 3b19901c9945..0f14cede4e5d 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 48db18de3dd3..c5dd6aa5ae1e 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 15d3ba7577fc..4dc00db23923 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 000000000000..e4cd78a65a43 --- /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 000000000000..77ba1b00bb78 --- /dev/null +++ b/web/panettone/test/package.lisp @@ -0,0 +1,2 @@ +(defpackage :panettone.tests + (:use :cl :klatre :fiveam)) |