diff options
Diffstat (limited to 'web/panettone/src')
-rw-r--r-- | web/panettone/src/authentication.lisp | 16 | ||||
-rw-r--r-- | web/panettone/src/css.lisp | 32 | ||||
-rw-r--r-- | web/panettone/src/migrations/1-init-schema.lisp | 23 | ||||
-rw-r--r-- | web/panettone/src/migrations/3920286378-add-issue-tsv.lisp | 5 | ||||
-rw-r--r-- | web/panettone/src/migrations/3921488651-create-users-table.lisp | 6 | ||||
-rw-r--r-- | web/panettone/src/model.lisp | 262 | ||||
-rw-r--r-- | web/panettone/src/packages.lisp | 16 | ||||
-rw-r--r-- | web/panettone/src/panettone.lisp | 55 | ||||
-rw-r--r-- | web/panettone/src/static/search.png | bin | 0 -> 711 bytes | |||
-rw-r--r-- | web/panettone/src/util.lisp | 24 |
10 files changed, 380 insertions, 59 deletions
diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp index 3ce07aa8d7..496a0e0bd7 100644 --- a/web/panettone/src/authentication.lisp +++ b/web/panettone/src/authentication.lisp @@ -42,23 +42,31 @@ the user, however email addresses are temporarily not available." (or (uiop:getenv "OAUTH2_REDIRECT_URI") "https://b.tvl.fyi/auth")) +(comment + (setq *oauth2-redirect-uri* "http://localhost:6161/auth") + ) + (defun initialise-oauth2 () "Initialise all settings needed for OAuth2" (setq *oauth2-auth-endpoint* - (or (uiop:getenv "OAUTH2_AUTH_ENDPOINT") + (or *oauth2-auth-endpoint* + (uiop:getenv "OAUTH2_AUTH_ENDPOINT") "https://auth.tvl.fyi/auth/realms/TVL/protocol/openid-connect/auth")) (setq *oauth2-token-endpoint* - (or (uiop:getenv "OAUTH2_TOKEN_ENDPOINT") + (or *oauth2-token-endpoint* + (uiop:getenv "OAUTH2_TOKEN_ENDPOINT") "https://auth.tvl.fyi/auth/realms/TVL/protocol/openid-connect/token")) (setq *oauth2-client-id* - (or (uiop:getenv "OAUTH2_CLIENT_ID") + (or *oauth2-client-id* + (uiop:getenv "OAUTH2_CLIENT_ID") "panettone")) (setq *oauth2-client-secret* - (or (uiop:getenv "OAUTH2_CLIENT_SECRET") + (or *oauth2-client-secret* + (uiop:getenv "OAUTH2_CLIENT_SECRET") (error "OAUTH2_CLIENT_SECRET must be set!")))) (defun auth-url () diff --git a/web/panettone/src/css.lisp b/web/panettone/src/css.lisp index aa753cb50f..3bba2bb591 100644 --- a/web/panettone/src/css.lisp +++ b/web/panettone/src/css.lisp @@ -49,7 +49,24 @@ :color "var(--primary)"))) (.comment-count - :color "var(--gray)"))) + :color "var(--gray)") + + (.issue-links + :display "flex" + :flex-direction "row" + :align-items "center" + :justify-content "space-between" + :flex-wrap "wrap") + + (.issue-search + ((:and input (:= type "search")) + :padding "0.5rem" + :background-image "url('static/search.png')" + :background-position "10px 10px" + :background-repeat "no-repeat" + :background-size "1rem" + :padding-left "2rem" + :border "1px" "solid" "var(--gray)")))) (defparameter issue-history-styles `((.issue-history @@ -220,4 +237,15 @@ :margin "0 auto") (.created-by-at - :color "var(--gray)"))) + :color "var(--gray)") + + ;; screen-reader-only content + (.sr-only + :border 0 + :clip "rect(0 0 0 0)" + :height "1px" + :margin "-1px" + :overflow "hidden" + :padding 0 + :position "absolute" + :width "1px"))) diff --git a/web/panettone/src/migrations/1-init-schema.lisp b/web/panettone/src/migrations/1-init-schema.lisp new file mode 100644 index 0000000000..3be6c4fcc0 --- /dev/null +++ b/web/panettone/src/migrations/1-init-schema.lisp @@ -0,0 +1,23 @@ +"Initialize the database schema from before migrations were added" + +(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 ,panettone.model:+issue-statuses+))))) + +(defun ddl/create-tables () + "Issue DDL to create all tables, if they don't already exist." + (dolist (table '(panettone.model:issue + panettone.model:issue-comment + panettone.model:issue-event + panettone.model:user-settings)) + (unless (table-exists-p (dao-table-name table)) + (create-table table)))) + +(defun up () + (ddl/create-issue-status) + (ddl/create-tables)) diff --git a/web/panettone/src/migrations/3920286378-add-issue-tsv.lisp b/web/panettone/src/migrations/3920286378-add-issue-tsv.lisp new file mode 100644 index 0000000000..2a965a7bba --- /dev/null +++ b/web/panettone/src/migrations/3920286378-add-issue-tsv.lisp @@ -0,0 +1,5 @@ +"Add tsvector for full-text search of issues" + +(defun up () + (query "ALTER TABLE issues ADD COLUMN tsv tsvector GENERATED ALWAYS AS (to_tsvector('english', subject || ' ' || body)) STORED") + (query "CREATE INDEX issues_tsv_index ON issues USING GIN (tsv);")) diff --git a/web/panettone/src/migrations/3921488651-create-users-table.lisp b/web/panettone/src/migrations/3921488651-create-users-table.lisp new file mode 100644 index 0000000000..2598ab101e --- /dev/null +++ b/web/panettone/src/migrations/3921488651-create-users-table.lisp @@ -0,0 +1,6 @@ +"Add a table to store information about users, load the initial set of users +from the authentication provider, and change fks for other tables" + +(defun up () + (panettone.model:create-table-if-not-exists + 'panettone.model:user)) diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp index c54a0ae474..a106e9479b 100644 --- a/web/panettone/src/model.lisp +++ b/web/panettone/src/model.lisp @@ -1,6 +1,8 @@ (in-package :panettone.model) (declaim (optimize (safety 3))) +(setq pomo:*ignore-unknown-columns* t) + (defvar *pg-spec* nil "Connection spec for use with the with-connection macro. Needs to be initialised at launch time.") @@ -20,10 +22,39 @@ initialised at launch time.") "Initialises the connection spec used for all Postgres connections." (setq *pg-spec* (make-pg-spec))) +(defun connect-to-db () + "Connect using *PG-SPEC* at the top-level, for use during development" + (apply #'connect-toplevel + (loop for v in *pg-spec* + until (eq v :pooled-p) + collect v))) + +(defun pg-spec->url (&optional (spec *pg-spec*)) + (destructuring-bind (db user password host &key port &allow-other-keys) spec + (format nil + "postgres://~A:~A@~A:~A/~A" + user password host port db))) + ;;; ;;; Schema ;;; +(defclass user () + ((sub :col-type uuid :initarg :sub :accessor sub + :documentation + "ID for the user in the authentication provider. Taken from the `:SUB' + field in the JWT when the user first logged in") + (username :col-type string :initarg :username :accessor username) + (email :col-type string :initarg :email :accessor email)) + (:metaclass dao-class) + (:keys sub) + (:table-name users) + (:documentation + "Panettone users. Uses an external authentication provider.")) + +(deftable (user "users") + (!dao-def)) + (defclass user-settings () ((user-dn :col-type string :initarg :user-dn :accessor user-dn) (enable-email-notifications @@ -77,15 +108,6 @@ initialised at launch time.") "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) @@ -192,23 +214,171 @@ its new value will be formatted using ~A into NEW-VALUE")) (!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) +(defclass migration () + ((version + :col-type bigint + :primary-key t + :initarg :version + :accessor version) + (name :col-type string :initarg :name :accessor name) + (docstring :col-type string :initarg :docstring :accessor docstring) + (path :col-type string + :type pathname + :initarg :path + :accessor path + :col-export namestring + :col-import parse-namestring) + (package :type keyword :initarg :package :accessor migration-package)) + (:metaclass dao-class) + (:keys version) + (:table-name migrations) + (:documentation "Migration scripts that have been run on the database")) +(deftable migration (!dao-def)) -(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)))) +;;; +;;; Utils +;;; + +(defun create-table-if-not-exists (name) + " Takes the name of a dao-class and creates the table identified by symbol by +executing all forms in its definition as found in the *tables* list, if it does +not already exist." + (unless (table-exists-p (dao-table-name name)) + (create-table name))) + +;;; +;;; Migrations +;;; -(defun ddl/init () - "Idempotently initialize the full database schema for Panettone" - (ddl/create-issue-status) - (ddl/create-tables)) +(defun ensure-migrations-table () + "Ensure the migrations table exists" + (unless (table-exists-p (dao-table-name 'migration)) + (create-table 'migration))) + +(define-build-time-var *migrations-dir* "migrations/" + "The directory where migrations are stored") + +(defun load-migration-docstring (migration-path) + "If the first form in the file pointed to by `migration-pathname` is + a string, return it, otherwise return NIL." + + (handler-case + (with-open-file (s migration-path) + (when-let ((form (read s))) + (when (stringp form) form))) + (t () nil))) + +(defun load-migration (path) + (let* ((parts (str:split #\- (pathname-name path) :limit 2)) + (version (parse-integer (car parts))) + (name (cadr parts)) + (docstring (load-migration-docstring path)) + (package (intern (format nil "MIGRATION-~A" version) + :keyword)) + (migration (make-instance 'migration + :version version + :name name + :docstring docstring + :path path + :package package))) + (uiop/package:ensure-package package + :use '(#:common-lisp + #:postmodern + #:panettone.model)) + (let ((*package* (find-package package))) + (load path)) + + migration)) + +(defun run-migration (migration) + (declare (type migration migration)) + (with-transaction () + (format t "Running migration ~A (version ~A)" + (name migration) + (version migration)) + (query + (sql-compile + `(:delete-from migrations + :where (= version ,(version migration))))) + (uiop:symbol-call (migration-package migration) :up) + (insert-dao migration))) + +(defun list-migration-files () + (remove-if-not + (lambda (pn) (string= "lisp" (pathname-type pn))) + (uiop:directory-files (util:->dir *migrations-dir*)))) + +(defun load-migrations () + (mapcar #'load-migration (list-migration-files))) + +(defun generate-migration (name &key documentation) + "Generate a new database migration with the given NAME, optionally +prepopulated with the given DOCUMENTATION. + +Returns the file that the migration is located at, as a `pathname'. Write Lisp +code in this migration file to define a function called `up', which will be run +in the context of a database transaction and should perform the migration." + (let* ((version (get-universal-time)) + (filename (format nil "~A-~A.lisp" + version + name)) + (pathname + (merge-pathnames filename *migrations-dir*))) + (with-open-file (stream pathname + :direction :output + :if-does-not-exist :create) + (when documentation + (format stream "~S~%~%" documentation)) + + (format stream "(defun up ()~%)")) + pathname)) + +(defun migrations-already-run () + "Query the database for a list of migrations that have already been run" + (query-dao 'migration (sql-compile '(:select * :from migrations)))) + +(define-condition migration-name-mismatch () + ((version :type integer :initarg :version) + (name-in-database :type string :initarg :name-in-database) + (name-in-code :type string :initarg :name-in-code)) + (:report + (lambda (cond stream) + (format stream "Migration mismatch: Migration version ~A has name ~S in the database, but we have name ~S" + (slot-value cond 'version) + (slot-value cond 'name-in-database) + (slot-value cond 'name-in-code))))) + +(defun migrate () + "Migrate the database, running all migrations that have not yet been run" + (ensure-migrations-table) + (format t "Running migrations from ~A...~%" *migrations-dir*) + (let* ((all-migrations (load-migrations)) + (already-run (migrations-already-run)) + (num-migrations-run 0)) + (iter (for migration in all-migrations) + (if-let ((existing (find-if (lambda (existing) + (= (version existing) + (version migration))) + already-run))) + (progn + (unless (string= (name migration) + (name existing)) + (restart-case + (error 'migration-name-mismatch + :version (version existing) + :name-in-database (name existing) + :name-in-code (name migration)) + (skip () + :report "Skip this migration" + (next-iteration)) + (run-and-overwrite () + :report "Run this migration anyway, overwriting the previous migration" + (run-migration migration)))) + (next-iteration)) + ;; otherwise, run the migration + (run-migration migration)) + (incf num-migrations-run)) + (format t "Ran ~A migration~:P~%" num-migrations-run))) ;;; ;;; Querying @@ -243,24 +413,31 @@ type `ISSUE-NOT-FOUND'." :where (:= 'id id)))) :single)) -(defun list-issues (&key status (with '(:num-comments))) +(defun list-issues (&key status search (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)))) + (let* ((conditions + (and-where* + (unless (null status) + `(:= status $1)) + (when (str:non-blank-string-p search) + `(:@@ tsv (:websearch-to-tsquery ,search))))) (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))) + :from issues + :left-join issue-comments + :on (:= issues.id issue-comments.issue-id) + :where ,conditions + :group-by issues.id) + `(:select * :from issues :where ,conditions))) + (order (if (str:non-blank-string-p search) + `(:desc (:ts-rank-cd tsv (:websearch-to-tsquery ,search))) + `(:desc id))) (query (sql-compile - `(:order-by ,select (:desc id))))) + `(:order-by ,select ,order)))) (with-column-writers ('num_comments 'num-comments) (query-dao 'issue query status)))) @@ -409,12 +586,23 @@ explicitly subscribing to / unsubscribing from individual issues." (comment - (ddl/init) + (make-instance 'issue :subject "test") - (create-issue :subject "test" - :author-dn "cn=grfn,ou=users,dc=tvl,dc=fyi") + + (with-connection *pg-spec* + (create-issue :subject "test" + :author-dn "cn=aspen,ou=users,dc=tvl,dc=fyi")) (issue-commenter-dns 1) (issue-subscribers 1) + ;; Creating new migrations + (setq *migrations-dir* (merge-pathnames "migrations/")) + (generate-migration "create-users-table" + :documentation "Add a table to store information about users") + (load-migrations) + + ;; Running migrations + (with-connection *pg-spec* + (migrate)) ) diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp index 4ff4c070f0..8e77c0ff2b 100644 --- a/web/panettone/src/packages.lisp +++ b/web/panettone/src/packages.lisp @@ -1,7 +1,10 @@ (defpackage panettone.util + (:nicknames :util) (:use :cl :klatre) (:import-from :alexandria :when-let) - (:export :integer-env :add-missing-base64-padding)) + (:export + :integer-env :add-missing-base64-padding :and-where :and-where* + :define-build-time-var :->dir)) (defpackage panettone.css (:use :cl :lass) @@ -36,16 +39,21 @@ (:import-from :alexandria :if-let :when-let :define-constant) (:export :prepare-db-connections - :ddl/init + :migrate :*pg-spec* + :create-table-if-not-exists + + :user + :sub :username :email + :user-settings :user-dn :enable-email-notifications-p :settings-for-user :update-user-settings :enable-email-notifications - :issue :issue-comment :issue-event + :issue :issue-comment :issue-event :migration :id :subject :body :author-dn :issue-id :status :created-at :acting-user-dn - :field :previous-value :new-value + :field :previous-value :new-value :+issue-statuses+ :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status :update-issue :delete-issue :issue-not-found :not-found-id diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp index d87ac5ed46..37d194d0f9 100644 --- a/web/panettone/src/panettone.lisp +++ b/web/panettone/src/panettone.lisp @@ -193,7 +193,21 @@ (who:esc (format nil "~A comment~:p" num-comments)))))))))))))) -(defun render/index (&key issues) +(defun render/issue-search (&key search) + (who:with-html-output (*standard-output*) + (:form + :method "get" + :class "issue-search" + (:input :type "search" + :name "search" + :title "Issue search query" + :value search) + (:input + :type "submit" + :value "Search Issues" + :class "sr-only")))) + +(defun render/index (&key issues search) (render () (:header (:h1 "Issues") @@ -205,17 +219,19 @@ (:main (:div :class "issue-links" - (:a :href "/issues/closed" "View closed issues")) + (:a :href "/issues/closed" "View closed issues") + (render/issue-search :search search)) (render/issue-list :issues issues)))) -(defun render/closed-issues (&key issues) +(defun render/closed-issues (&key issues search) (render () (:header (:h1 "Closed issues")) (:main (:div :class "issue-links" - (:a :href "/" "View open isues")) + (:a :href "/" "View open isues") + (render/issue-search :search search)) (render/issue-list :issues issues)))) (defun render/issue-form (&optional issue message) @@ -442,9 +458,11 @@ given subject an body (in a thread, to avoid blocking)" (hunchentoot:delete-session-value 'user) (hunchentoot:redirect "/")) -(defroute index ("/" :decorators (@auth-optional @db)) () - (let ((issues (model:list-issues :status :open))) - (render/index :issues issues))) +(defroute index ("/" :decorators (@auth-optional @db)) (&get search) + (let ((issues (model:list-issues :status :open + :search search))) + (render/index :issues issues + :search search))) (defroute settings ("/settings" :method :get :decorators (@auth @db)) () (render/settings)) @@ -458,9 +476,12 @@ given subject an body (in a thread, to avoid blocking)" (render/settings))) (defroute handle-closed-issues - ("/issues/closed" :decorators (@auth-optional @db)) () - (let ((issues (model:list-issues :status :closed))) - (render/closed-issues :issues issues))) + ("/issues/closed" :decorators (@auth-optional @db)) + (&get search) + (let ((issues (model:list-issues :status :closed + :search search))) + (render/closed-issues :issues issues + :search search))) (defroute new-issue ("/issues/new" :decorators (@auth)) () (render/issue-form)) @@ -606,7 +627,10 @@ given subject an body (in a thread, to avoid blocking)" (defun migrate-db () "Migrate the database to the latest version of the schema" (pomo:with-connection *pg-spec* - (model:ddl/init))) + (model:migrate))) + +(define-build-time-var *static-dir* "static/" + "Directory to serve static files from") (defun start-panettone (&key port session-secret) (authn:initialise-oauth2) @@ -619,7 +643,14 @@ given subject an body (in a thread, to avoid blocking)" (setq hunchentoot:*session-max-time* (* 60 60 24 90)) (setq *acceptor* - (make-instance 'easy-routes:routes-acceptor :port port)) + (make-instance 'easy-routes:easy-routes-acceptor :port port)) + + (push + (hunchentoot:create-folder-dispatcher-and-handler + "/static/" + (util:->dir *static-dir*)) + hunchentoot:*dispatch-table*) + (hunchentoot:start *acceptor*)) (defun main () diff --git a/web/panettone/src/static/search.png b/web/panettone/src/static/search.png new file mode 100644 index 0000000000..0fd78c6651 --- /dev/null +++ b/web/panettone/src/static/search.png Binary files differdiff --git a/web/panettone/src/util.lisp b/web/panettone/src/util.lisp index 2abedf7b8f..4c3c4f1aa6 100644 --- a/web/panettone/src/util.lisp +++ b/web/panettone/src/util.lisp @@ -13,3 +13,27 @@ that it can be successfully decoded by the `BASE64' package" (let* ((needed-padding (mod (length s) 4)) (pad-chars (if (zerop needed-padding) 0 (- 4 needed-padding)))) (format nil "~A~v@{~A~:*~}" s pad-chars "="))) + +(defun and-where (clauses) + "Combine all non-nil clauses in CLAUSES into a single S-SQL WHERE form" + (let ((clauses (remove nil clauses))) + (if (null clauses) t + (reduce (lambda (x y) `(:and ,x ,y)) clauses)))) + +(defun and-where* (&rest clauses) + "Combine all non-nil clauses in CLAUSES into a single S-SQL WHERE form" + (and-where clauses)) + +(defmacro define-build-time-var + (name value-if-not-in-build &optional (doc nil)) + `(defvar ,name + (or (when-let ((package (find-package :build))) + (let ((sym (find-symbol ,(symbol-name name) package))) + (when (boundp sym) (symbol-value sym)))) + ,value-if-not-in-build) + ,doc)) + +(defun ->dir (dir) + (if (char-equal (uiop:last-char dir) #\/) + dir + (concatenate 'string dir "/"))) |