feat(web/panettone): Support full-text search of issues r/7828

Support basic full text search of issues using postgresql's built-in
text search. There's a new column on the issues table called `tsv`,
which contains a tsvector of the title concatenated with the
description, and a new search form on both the index and closed issues
page which allows searching that tsvector with a user-supplied query.
Results are ranked according to that text query in the case of a search.

This works fine for now, but next up I'd also like to highlight the
results according to the bits that matched the user's query.

Change-Id: I25170bedbbbcdc3ed29a047962e9fcfe280d763a
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11258
Autosubmit: aspen <root@gws.fyi>
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>

7 files changed, 126 insertions, 36 deletions

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/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/model.lisp b/web/panettone/src/model.lisp
index aa52b4a493..5dff14818e 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 c8c1842f44..cc53be6cb0 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 bdcf0d05b3..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))
@@ -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 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..c9d86cbfb3 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 "/")))