diff options
| -rw-r--r-- | web/panettone/default.nix | 2 | ||||
| -rw-r--r-- | web/panettone/src/model.lisp | 225 | ||||
| -rw-r--r-- | web/panettone/src/packages.lisp | 28 | ||||
| -rw-r--r-- | web/panettone/src/panettone.lisp | 248 | ||||
| -rw-r--r-- | web/panettone/src/util.lisp | 7 |
5 files changed, 394 insertions, 116 deletions
diff --git a/web/panettone/default.nix b/web/panettone/default.nix index 2de000b7e852..93000b0f50a1 100644 --- a/web/panettone/default.nix +++ b/web/panettone/default.nix @@ -12,6 +12,7 @@ depot.nix.buildLisp.program { hunchentoot lass local-time + postmodern trivial-ldap depot.lisp.klatre @@ -21,6 +22,7 @@ depot.nix.buildLisp.program { ./panettone.asd ./src/packages.lisp ./src/css.lisp + ./src/model.lisp ./src/panettone.lisp ]; } diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp new file mode 100644 index 000000000000..3b19901c9945 --- /dev/null +++ b/web/panettone/src/model.lisp @@ -0,0 +1,225 @@ +(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 issue () + ((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) + (num-comments :type integer :accessor num-comments) + (status :col-type issue_status + :initarg :status + :accessor status + :initform :open + :col-default "open") + (created-at :col-type timestamp + :col-default (local-time:now) + :accessor created-at)) + (: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")) + +(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)) + +(deftable issue (!dao-def)) + +(defclass issue-comment () + ((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)) + (: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)) + +(defmethod initialize-instance :after + ((issue-comment issue-comment) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (created-at->timestamp issue-comment)) + +(defun ddl/create-tables () + "Issue DDL to create all tables, if they don't already exist." + (dolist (table '(issue issue-comment)) + (unless (table-exists-p (dao-table-name table)) + (create-table table)))) + +(defun ddl/init () + "Idempotently nitialize 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)))) + +;;; +;;; Writing +;;; + +(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) + (when (zerop (execute (:update 'issues + :set 'status (cl-postgres:to-sql-string status) + :where (:= 'id issue-id)))) + (error 'issue-not-found :id issue-id))) + +(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") + ) diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp index 8ebf528cca70..169d8833a7bd 100644 --- a/web/panettone/src/packages.lisp +++ b/web/panettone/src/packages.lisp @@ -1,10 +1,36 @@ +(defpackage panettone.util + (:use :cl :klatre) + (:import-from :alexandria :when-let) + (:export :integer-env)) + (defpackage panettone.css (:use :cl :lass) (:export :styles)) +(defpackage panettone.model + (:nicknames :model) + (:use :cl :panettone.util :klatre :postmodern) + (:import-from :alexandria :if-let :define-constant) + (:export + :connect-postgres :ddl/init + + :issue + :issue-comment + :id :subject :body :author-dn :issue-id :status :created-at + + :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status + :delete-issue + + :issue-comments :num-comments :create-issue-comment)) + (defpackage panettone - (:use :cl :klatre :easy-routes) + (:use :cl :panettone.util :klatre :easy-routes :iterate) (:import-from :cl-prevalence :get-id) (:import-from :defclass-std :defclass/std) (:import-from :alexandria :if-let :when-let) + (:import-from + :panettone.model + :id :subject :body :author-dn :issue-id :status :created-at + :issue-comments :num-comments) + (:shadow :next) (:export :start-pannetone :config :main)) diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp index 7d29edb7ac75..07285e69303a 100644 --- a/web/panettone/src/panettone.lisp +++ b/web/panettone/src/panettone.lisp @@ -5,14 +5,15 @@ ;;; Data model ;;; -(deftype issue-status () - '(member :open :closed)) +(deftype issue-status () '(member :open :closed)) (defclass/std issue-comment () ((body :type string) (author-dn :type string) (created-at :type local-time:timestamp - :std (local-time:now)))) + :std (local-time:now))) + (:documentation + "DEPRECATED: use `PANETTONE.MODEL::ISSUE-COMMENT' instead")) (defclass/std issue (cl-prevalence:object-with-id) ((subject body :type string :std "") @@ -20,7 +21,9 @@ (comments :std nil :type list :with-prefix) (status :std :open :type issue-status) (created-at :type local-time:timestamp - :std (local-time:now)))) + :std (local-time:now))) + (:documentation + "DEPRECATED: use `PANETTONE.MODEL::ISSUE' instead")) (defclass/std user () ((cn dn mail displayname :type string))) @@ -84,12 +87,12 @@ successful, `nil' otherwise" (when-let ((user (if (typep user-or-username 'user) user-or-username (find-user user-or-username)))) (let ((dn (dn user))) - (multiple-value-bind (_r code-sym _msg) - (ldap:bind - (ldap:new-ldap :host (ldap:host *ldap*) - :port (ldap:port *ldap*) - :user dn - :pass password)) + (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))))) @@ -103,58 +106,6 @@ successful, `nil' otherwise" (defvar *p-system* nil "The persistence system for this instance of Panettone") -(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 (system id) - (restart-case - (or - (cl-prevalence:find-object-with-id system '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 system new-id)))) - -(defun list-issues (system) - (cl-prevalence:find-all-objects system 'issue)) - -(defun issues-with-status (system status) - (remove-if-not (lambda (issue) (eq (status issue) status)) - (list-issues system))) - -(defun open-issues (system) (issues-with-status system :open)) -(defun closed-issues (system) (issues-with-status system :closed)) - -(defun create-issue (system &rest attrs) - (cl-prevalence:tx-create-object - system - 'issue - (chunk-list 2 attrs))) - -(defun add-comment (system issue-id &rest attrs) - "Add a comment with the given ATTRS to the issue ISSUE-ID, and return the -updated issue" - (let* ((comment (apply #'make-instance 'issue-comment attrs)) - (issue (get-issue system issue-id)) - (comments (append (issue-comments issue) - (list comment)))) - (cl-prevalence:tx-change-object-slots - system - 'issue - issue-id - `((comments ,comments))) - (setf (slot-value issue 'comments) comments) - comments)) - (defun initialize-persistence (data-dir) "Initialize the Panettone persistence system, storing data in DATA-DIR" (ensure-directories-exist data-dir) @@ -165,9 +116,67 @@ updated issue" "/snapshot.xml"))) - (when (null (list-issues *p-system*)) + (when (null (cl-prevalence:find-all-objects *p-system* 'issue)) (cl-prevalence:tx-create-id-counter *p-system*))) +(defun prevalence->postgresql (system &key force) + "Idempotently migrate all data from the cl-prevalence system SYSTEM into the +global postgresql connection (eg as initialized by +`model:connect-postgres'). With FORCE=t, will clear the database first" + (pomo:with-transaction (prevalence->postgresql) + (when force + (pomo:query (:delete-from 'issues))) + (iter + (for issue in (cl-prevalence:find-all-objects system 'issue)) + (counting + (unless (model:issue-exists-p (get-id issue)) + (model:create-issue + :id (get-id issue) + :subject (subject issue) + :body (or (body issue) "") + :status (status issue) + :author-dn (author-dn issue) + :created-at (created-at issue))) + into num-issues) + (sum + (iter + (for comment in (issue-comments issue)) + (counting + (unless (pomo:query + (:select + (:exists + (:select 1 + :from 'issue_comments + :where (:and + (:= 'issue_id (get-id issue)) + (:= 'body (body comment)) + (:= 'author_dn (author-dn comment)))))) + :single) + (model:create-issue-comment + :body (body comment) + :author-dn (author-dn comment) + :issue-id (get-id issue) + :created-at (created-at comment))))) + into num-comments) + (finally + (let ((next-id (pomo:query + (:select (:+ 1 (:max 'id)) + :from 'issues) + :single))) + (pomo:query + (pomo:sql-compile + `(:alter-sequence issues_id_seq :restart ,next-id)))) + (format t "Created ~A issues and ~A comments~&" + num-issues num-comments) + (return (values num-issues num-comments)))))) + +(comment + (initialize-persistence "/home/grfn/code/depot/web/panettone/") + (model:connect-postgres) + (model:ddl/init) + (prevalence->postgresql *p-system* :force t) + ) + ;;; ;;; Views ;;; @@ -178,7 +187,7 @@ updated issue" (setf (who:html-mode) :html5) -(defun render/footer-nav (&rest extra) +(defun render/footer-nav () (who:with-html-output (*standard-output*) (:footer (:nav @@ -250,6 +259,7 @@ updated issue" :value "Submit")))))) (defun created-by-at (issue) + (check-type issue model:issue) (who:with-html-output (*standard-output*) (:span :class "created-by-at" "Opened by " @@ -269,7 +279,7 @@ updated issue" (:ol :class "issue-list" (dolist (issue issues) - (let ((issue-id (get-id issue))) + (let ((issue-id (model:id issue))) (who:htm (:li (:a :href (format nil "/issues/~A" issue-id) @@ -350,8 +360,8 @@ updated issue" :value "Comment")))) (defun render/issue (issue) - (check-type issue issue) - (let ((issue-id (get-id issue)) + (check-type issue model:issue) + (let ((issue-id (id issue)) (issue-status (status issue))) (render () (:header @@ -397,7 +407,7 @@ updated issue" " at " (who:esc (format-dottime (created-at comment))))))))) (when *user* - (render/new-comment (get-id issue)))))))))) + (render/new-comment (id issue)))))))))) (defun render/not-found (entity-type) (render () @@ -420,6 +430,22 @@ updated issue" (hunchentoot:request-uri*) :utf-8))))) +(defun @txn (next) + (pomo:with-transaction () + (catch + ;; 'hunchentoot:handler-done is unexported, but is used by functions + ;; like hunchentoot:redirect to nonlocally abort the request handler - + ;; this doesn't mean an error occurred, so we need to catch it here to + ;; make the transaction still get committed + (intern "HANDLER-DONE" "HUNCHENTOOT") + (funcall next)))) + +(defun @handle-issue-not-found (next) + (handler-case (funcall next) + (issue-not-found (err) + (render/not-found + (format nil "Issue #~A" (model:id err)))))) + (defroute login-form ("/login" :method :get) (original-uri) (if (hunchentoot:session-value 'user) @@ -439,84 +465,69 @@ updated issue" (hunchentoot:redirect "/")) (defroute index ("/" :decorators (@auth-optional)) () - (let ((issues (open-issues *p-system*))) + (let ((issues (model:list-issues :status :open))) (render/index :issues issues))) (defroute handle-closed-issues ("/issues/closed" :decorators (@auth-optional)) () - (let ((issues (closed-issues *p-system*))) + (let ((issues (model:list-issues :status :closed))) (render/closed-issues :issues issues))) (defroute new-issue ("/issues/new" :decorators (@auth)) () (render/new-issue)) (defroute handle-create-issue - ("/issues" :method :post :decorators (@auth)) + ("/issues" :method :post :decorators (@auth @txn)) (&post subject body) (if (string= subject "") (render/new-issue "Subject is required") (progn - (cl-prevalence:execute-transaction - (create-issue *p-system* - 'subject subject - 'body body - 'author-dn (dn *user*))) - (cl-prevalence:snapshot *p-system*) + (model:create-issue :subject subject + :body body + :author-dn (dn *user*)) (hunchentoot:redirect "/")))) -(defroute show-issue ("/issues/:id" :decorators (@auth-optional)) +(defroute show-issue + ("/issues/:id" :decorators (@auth-optional @handle/issue-not-found)) (&path (id 'integer)) (handler-case - (let* ((issue (get-issue *p-system* id)) + (let* ((issue (model:get-issue id)) (*title* (format nil "~A | Panettone" (subject issue)))) (render/issue issue)) (issue-not-found (_) + (declare (ignore _)) (render/not-found "Issue")))) (defroute handle-create-comment - ("/issues/:id/comments" :decorators (@auth) - :method :post) + ("/issues/:id/comments" + :decorators (@auth @handle-issue-not-found @txn) + :method :post) (&path (id 'integer) &post body) (flet ((redirect-to-issue () (hunchentoot:redirect (format nil "/issues/~A" id)))) - (if (string= body "") - (redirect-to-issue) - (handler-case - (progn - (cl-prevalence:execute-transaction - (add-comment *p-system* id - :body body - :author-dn (dn *user*))) - (cl-prevalence:snapshot *p-system*) - (redirect-to-issue)) - (issue-not-found (_) - (render/not-found "Issue")))))) + (cond + ((string= body "") + (redirect-to-issue)) + (:else + (model:create-issue-comment + :issue-id id + :body body + :author-dn (dn *user*)) + (redirect-to-issue))))) (defroute close-issue - ("/issues/:id/close" :decorators (@auth) + ("/issues/:id/close" :decorators (@auth @handle-issue-not-found @txn) :method :post) (&path (id 'integer)) - (cl-prevalence:execute-transaction - (cl-prevalence:tx-change-object-slots - *p-system* - 'issue - id - '((status :closed)))) - (cl-prevalence:snapshot *p-system*) + (model:set-issue-status id :closed) (hunchentoot:redirect (format nil "/issues/~A" id))) (defroute open-issue ("/issues/:id/open" :decorators (@auth) :method :put) (&path (id 'integer)) - (cl-prevalence:execute-transaction - (cl-prevalence:tx-change-object-slots - *p-system* - 'issue - id - '((status open)))) - (cl-prevalence:snapshot *p-system*) + (model:set-issue-status id :open) (hunchentoot:redirect (format nil "/issues/~A" id))) (defroute styles ("/main.css") () @@ -526,23 +537,30 @@ updated issue" (defvar *acceptor* nil "Hunchentoot acceptor for Panettone's web server.") +(defun migrate-db () + "Migrate the database to the latest version of the schema + +In this iteration, intiialize the DDL and move all data from the prevalence +snapshot to the DB. In future iterations, this will do things like adding new +tables and columns" + (model:ddl/init) + (prevalence->postgresql *p-system*)) + (defun start-panettone (&key port data-dir (ldap-host "localhost") - (ldap-port 389)) + (ldap-port 389) + postgres-params) (connect-ldap :host ldap-host :port ldap-port) + (initialize-persistence data-dir) + (apply #'model:connect-postgres postgres-params) + (migrate-db) (setq *acceptor* (make-instance 'easy-routes:routes-acceptor :port port)) (hunchentoot:start *acceptor*)) -(defun integer-env (var &key default) - (or - (when-let ((str (uiop:getenvp var))) - (try-parse-integer str)) - default)) - (defun main () (let ((port (integer-env "PANETTONE_PORT" :default 6161)) (ldap-port (integer-env "LDAP_PORT" :default 389)) diff --git a/web/panettone/src/util.lisp b/web/panettone/src/util.lisp new file mode 100644 index 000000000000..9fd9ceaa79a4 --- /dev/null +++ b/web/panettone/src/util.lisp @@ -0,0 +1,7 @@ +(in-package :panettone.util) + +(defun integer-env (var &key default) + (or + (when-let ((str (uiop:getenvp var))) + (try-parse-integer str)) + default)) |