[bug#39258] [PATCH v2 2/3] gnu: Generate Xapian package search index.

[Arun Isaac <arunisaac@systemreboot.net>]

* guix/ui.scm: Export %package-metrics.
* gnu/packages.scm (%package-search-index): New variable.
(generate-package-search-index): New function.
* guix/channels.scm (package-search-index): New function.
(%channel-profile-hooks): Add package-search-index.
---
 gnu/packages.scm  | 42 +++++++++++++++++++++++++++++++++++++++++-
 guix/channels.scm | 34 +++++++++++++++++++++++++++++++++-
 guix/ui.scm       |  2 ++
 3 files changed, 76 insertions(+), 2 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index d22c992bb1..c8e221de68 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,6 +44,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-39)
+  #:use-module (xapian xapian)
   #:export (search-patch
             search-patches
             search-auxiliary-file
@@ -64,7 +66,8 @@
             specification->location
             specifications->manifest
 
-            generate-package-cache))
+            generate-package-cache
+            generate-package-search-index))
 
 ;;; Commentary:
 ;;;
@@ -426,6 +429,43 @@ reducing the memory footprint."
                                #:opts '(#:to-file? #t)))))
   cache-file)
 
+(define %package-search-index
+  ;; Location of the package search-index
+  "/lib/guix/package-search.index")
+
+(define (generate-package-search-index directory)
+  "Generate under DIRECTORY a Xapian index of all the available packages."
+  (define db-path
+    (string-append directory %package-search-index))
+
+  (mkdir-p (dirname db-path))
+  (call-with-writable-database db-path
+    (lambda (db)
+      (fold-packages (lambda (package _)
+                       (let* ((idterm (string-append "Q" (package-name package)))
+                              (doc (make-document #:data (string-trim-right
+                                                          (call-with-output-string
+                                                            (cut package->recutils package <>))
+                                                          #\newline)
+                                                  #:terms `((,idterm . 0))))
+                              (term-generator (make-term-generator #:stem (make-stem "en")
+                                                                   #:document doc)))
+                         (for-each (match-lambda
+                                     ((field . weight)
+                                      (match (field package)
+                                        ((? string? str)
+                                         (index-text! term-generator str
+                                                      #:wdf-increment weight))
+                                        ((lst ...)
+                                         (for-each (cut index-text! term-generator <>
+                                                        #:wdf-increment weight)
+                                                   lst)))
+                                      (replace-document! db idterm doc)))
+                                   %package-metrics)))
+                     #f)))
+
+  db-path)
+
 \f
 (define %sigint-prompt
   ;; The prompt to jump to upon SIGINT.
diff --git a/guix/channels.scm b/guix/channels.scm
index f0261dc2da..c70c70938c 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -581,9 +582,40 @@ be used as a profile hook."
                                                  (hook . package-cache))
                                   #:local-build? #t)))
 
+(define (package-search-index manifest)
+  "Build a package search index for the instance in MANIFEST.  This is meant
+to be used as a profile hook."
+  (mlet %store-monad ((profile (profile-derivation manifest
+                                                   #:hooks '())))
+
+    (define build
+      #~(begin
+          (use-modules (gnu packages))
+
+          (if (defined? 'generate-package-search-index)
+              (begin
+                ;; Delegate package search index generation to the inferior.
+                (format (current-error-port)
+                        "Generating package search index for '~a'...~%"
+                        #$profile)
+                (generate-package-search-index #$output))
+              (mkdir #$output))))
+
+    (gexp->derivation-in-inferior "guix-package-search-index" build
+                                  profile
+
+                                  ;; If the Guix in PROFILE is too old and
+                                  ;; lacks 'guix repl', don't build the cache
+                                  ;; instead of failing.
+                                  #:silent-failure? #t
+
+                                  #:properties '((type . profile-hook)
+                                                 (hook . package-search-index))
+                                  #:local-build? #t)))
+
 (define %channel-profile-hooks
   ;; The default channel profile hooks.
-  (cons package-cache-file %default-profile-hooks))
+  (cons* package-cache-file package-search-index %default-profile-hooks))
 
 (define (channel-instances->derivation instances)
   "Return the derivation of the profile containing INSTANCES, a list of
diff --git a/guix/ui.scm b/guix/ui.scm
index fbe2b70485..3bc82111a5 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -14,6 +14,7 @@
 ;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -120,6 +121,7 @@
             relevance
             package-relevance
             display-search-results
+            %package-metrics
 
             with-profile-lock
             string->generations
-- 
2.25.1