From 223df46be51d641279f98ff5f9cb6a9b477e09c6 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Sat, 25 Jun 2022 14:48:47 +0530
Subject: bin: Index issues using xapian.

* bin/tissue: Import (ice-9 ftw), (git), (xapian wrap) and (xapian
xapian).
(delete-xapian-index): New function.
(%state-directory, %xapian-index): New variables.
(main): Build index if it does not exist.
* tissue/issue.scm: Import (xapian xapian).
(index-person): New function.
(index-issue): New public function.
---
 bin/tissue       | 42 ++++++++++++++++++++++++++++++++++++++++++
 tissue/issue.scm | 37 ++++++++++++++++++++++++++++++++++++-
 2 files changed, 78 insertions(+), 1 deletion(-)

diff --git a/bin/tissue b/bin/tissue
index 2deb23d..85f18b9 100755
--- a/bin/tissue
+++ b/bin/tissue
@@ -28,10 +28,14 @@ exec guile --no-auto-compile -s "$0" "$@"
         (srfi srfi-37)
         (srfi srfi-171)
         (srfi srfi-171 gnu)
+        (ice-9 ftw)
         (ice-9 match)
         (ice-9 popen)
         (ice-9 regex)
         (term ansi-color)
+        (git)
+        (xapian wrap)
+        (xapian xapian)
         (tissue conditions)
         (tissue git)
         (tissue issue)
@@ -39,6 +43,12 @@ exec guile --no-auto-compile -s "$0" "$@"
         (tissue utils)
         (tissue web))
 
+(define %state-directory
+  ".tissue")
+
+(define %xapian-index
+  (string-append %state-directory "/xapian"))
+
 (define (invoke program . args)
   (unless (zero? (apply system* program args))
     (error "Invocation of program failed" (cons program args))))
@@ -328,6 +338,16 @@ To get usage information for one of these sub-commands, run
           (command-line-program)
           (command-line-program)))
 
+(define (delete-xapian-index)
+  "Delete xapian index if it exists. Current directory must be at the
+top-level of the git repository."
+  (when (file-exists? %xapian-index)
+    (for-each (lambda (file)
+                (delete-file (string-append %xapian-index "/" file)))
+              (scandir %xapian-index
+                       (negate (cut member <> (list "." "..")))))
+    (rmdir %xapian-index)))
+
 (define main
   (match-lambda*
     ((_ (or "-h" "--help"))
@@ -343,6 +363,28 @@ To get usage information for one of these sub-commands, run
          (lambda ()
            (parameterize ((%issue-files (tissue-configuration-issue-files (load-config)))
                           (%aliases (tissue-configuration-aliases (load-config))))
+             ;; Create hidden tissue directory unless it exists.
+             (unless (file-exists? %state-directory)
+               (mkdir %state-directory))
+             ;; Ensure index exists rebuilding it if it is stale.
+             (let ((current-head
+                    (oid->string (reference-name->oid
+                                  (current-git-repository) "HEAD"))))
+               (unless (and (file-exists? %xapian-index)
+                            (string=? (call-with-database %xapian-index
+                                        (cut Database-get-metadata <> "commit"))
+                                      current-head))
+                 (guard (c (else (delete-xapian-index)
+                                 (display "Building xapian index failed."
+                                          (current-error-port))
+                                 (raise c)))
+                   (delete-xapian-index)
+                   (call-with-writable-database %xapian-index
+                     (lambda (db)
+                       (for-each (cut index-issue db <>)
+                                 (issues))
+                       (WritableDatabase-set-metadata db "commit" current-head))))))
+             ;; Handle sub-command.
              (apply (match command
                       ("list" tissue-list)
                       ("show" tissue-show)
diff --git a/tissue/issue.scm b/tissue/issue.scm
index 3b6c015..f8426ee 100644
--- a/tissue/issue.scm
+++ b/tissue/issue.scm
@@ -28,6 +28,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (git)
+  #:use-module (xapian xapian)
   #:use-module (tissue git)
   #:use-module (tissue utils)
   #:export (%issue-files
@@ -53,7 +54,8 @@
             post->alist
             alist->post
             authors
-            issues))
+            issues
+            index-issue))
 
 (define %issue-files
   (make-parameter #f))
@@ -326,3 +328,36 @@ in (tissue tissue). If no alias is found, NAME is returned as such."
              (lambda (issue1 issue2)
                (time<? (date->time-monotonic (issue-created-date issue1))
                        (date->time-monotonic (issue-created-date issue2)))))))))
+
+(define (index-person term-generator name prefix)
+  "Index all aliases of person of canonical NAME using TERM-GENERATOR
+with PREFIX."
+  (for-each (cut index-text! term-generator <> #:prefix prefix)
+            (or (assoc name (%aliases))
+                (list))))
+
+(define (index-issue db issue)
+  "Index ISSUE in writable xapian DB."
+  (let* ((idterm (string-append "Q" (issue-file issue)))
+         (body (call-with-input-file (issue-file issue)
+                 get-string-all))
+         (doc (make-document #:data (call-with-output-string
+                                      (cut write (issue->alist issue) <>))
+                             #:terms `((,idterm . 0))))
+         (term-generator (make-term-generator #:stem (make-stem "en")
+                                              #:document doc)))
+    ;; Index metadata with various prefixes.
+    (index-text! term-generator (issue-title issue) #:prefix "S")
+    (index-person term-generator (issue-creator issue) "A")
+    (index-person term-generator (issue-last-updater issue) "XA")
+    (for-each (cut index-person term-generator <> "XI")
+              (issue-assigned issue))
+    (for-each (cut index-text! term-generator <> #:prefix "K")
+              (issue-keywords issue))
+    (index-text! term-generator
+                 (if (issue-open? issue) "open" "closed")
+                 #:prefix "XS")
+    ;; Index body without prefixes for free text search.
+    (index-text! term-generator body)
+    ;; Add document to database.
+    (replace-document! db idterm doc)))
-- 
cgit v1.2.3