diff options
| -rw-r--r-- | web/panettone/src/css.lisp | 32 | ||||
| -rw-r--r-- | web/panettone/src/migrations/3920286378-add-issue-tsv.lisp | 5 | ||||
| -rw-r--r-- | web/panettone/src/model.lisp | 44 | ||||
| -rw-r--r-- | web/panettone/src/packages.lisp | 5 | ||||
| -rw-r--r-- | web/panettone/src/panettone.lisp | 53 | ||||
| -rw-r--r-- | web/panettone/src/static/search.png | bin | 0 -> 711 bytes | |||
| -rw-r--r-- | web/panettone/src/util.lisp | 23 |
7 files changed, 126 insertions, 36 deletions
diff --git a/web/panettone/src/css.lisp b/web/panettone/src/css.lisp index aa753cb50fc5..3bba2bb591bc 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/3920286378-add-issue-tsv.lisp b/web/panettone/src/migrations/3920286378-add-issue-tsv.lisp new file mode 100644 index 000000000000..2a965a7bba80 --- /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/model.lisp b/web/panettone/src/model.lisp index aa52b4a49320..5dff14818ebe 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.") @@ -226,14 +228,8 @@ its new value will be formatted using ~A into NEW-VALUE")) (unless (table-exists-p (dao-table-name 'migration)) (create-table 'migration))) -(defvar *migrations-dir* - ;; Let the nix build override the migrations dir for us - (or (when-let ((package (find-package :build))) - (let ((sym (find-symbol "*MIGRATIONS-DIR*" package))) - (when (boundp sym) - (symbol-value sym)))) - "migrations/") - "The directory where migrations are stored") +(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 @@ -281,12 +277,9 @@ its new value will be formatted using ~A into NEW-VALUE")) (insert-dao migration))) (defun list-migration-files () - (let ((dir (if (char-equal (uiop:last-char *migrations-dir*) #\/) - *migrations-dir* - (concatenate 'string *migrations-dir* "/")))) - (remove-if-not - (lambda (pn) (string= "lisp" (pathname-type pn))) - (uiop:directory-files dir)))) + (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))) @@ -392,24 +385,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 + :where ,conditions :group-by issues.id) - `(:select * :from issues ,@condition))) + `(: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)))) @@ -570,8 +570,8 @@ explicitly subscribing to / unsubscribing from individual issues." ;; Creating new migrations (setq *migrations-dir* (merge-pathnames "migrations/")) - (generate-migration "init-schema" - :documentation "Initialize the database schema") + (generate-migration "add-issue-tsv" + :documentation "Add tsvector for full-text search of issues") ;; Running migrations (with-connection *pg-spec* diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp index c8c1842f440e..cc53be6cb02f 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) diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp index bdcf0d05b39b..37d194d0f9af 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)) @@ -608,6 +629,9 @@ given subject an body (in a thread, to avoid blocking)" (pomo:with-connection *pg-spec* (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) (model:prepare-db-connections) @@ -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 000000000000..0fd78c665120 --- /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 2abedf7b8fbb..c9d86cbfb32d 100644 --- a/web/panettone/src/util.lisp +++ b/web/panettone/src/util.lisp @@ -13,3 +13,26 @@ 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" + (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)))) + (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 "/"))) |
