diff options
| -rwxr-xr-x | bin/tissue | 42 | ||||
| -rw-r--r-- | tissue/issue.scm | 37 |
2 files changed, 78 insertions, 1 deletions
@@ -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))) |