Subject: [bug#62264] [PATCH core-updates 1-6/6] Add `guix index` subcommand

From: "Antoine R. Dumont" <[email-masked]>
Date: Sat, 18 Mar 2023 17:57:10 +0100

Hello again,

please find enclosed the remaining patches holding the actual guix
subcommand as described in the introductory email.

Cheers,
--
tony / Antoine R. Dumont (@ardumont)

-----------------------------------------------------------------
gpg fingerprint BF00 203D 741A C9D5 46A8 BE07 52E2 E984 0D10 C3B8
From 869d8b4cc7cefb6d7dbe9cd1374242bf6d7c953d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Wed, 30 Nov 2022 15:25:21 +0100
Subject: [PATCH core-updates 1/6] index: Add initial implementation from
 civodul

Related to https://lists.gnu.org/archive/html/guix-devel/2022-01/msg00354.html
---
 guix/extensions/index.scm | 574 ++++++++++++++++++++++++++++++++++++++
 guix/scripts/home.scm     |   2 +-
 2 files changed, 575 insertions(+), 1 deletion(-)
 create mode 100644 guix/extensions/index.scm

diff --git a/guix/extensions/index.scm b/guix/extensions/index.scm
new file mode 100644
index 0000000000..d9894b213e
--- /dev/null
+++ b/guix/extensions/index.scm
@@ -0,0 +1,574 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Ludovic Courtès <[email-masked]>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix extensions index)
+  #:use-module ((guix i18n) #:select (G_))
+  #:use-module ((guix ui) #:select (show-version-and-exit
+                                    show-bug-report-information
+                                    with-error-handling
+                                    string->number*))
+  #:use-module (guix scripts)
+  #:use-module (sqlite3)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (guix describe)
+  #:use-module (guix store)
+  #:use-module (guix monads)
+  #:autoload   (guix combinators) (fold2)
+  #:autoload   (guix grafts) (%graft?)
+  #:autoload   (guix store roots) (gc-roots)
+  #:use-module (guix derivations)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module ((guix progress) #:select (progress-reporter/bar
+                                          call-with-progress-reporter))
+  #:use-module (guix sets)
+  #:use-module ((guix utils) #:select (cache-directory))
+  #:autoload   (guix build utils) (find-files)
+  #:autoload   (gnu packages) (fold-packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-37)  ;; option
+  #:use-module (srfi srfi-71)
+  #:export     (guix-index))
+
+(define debug #f)
+
+(define application-version 2)
+
+;; The following schema is the full schema at the `application-version`.  It
+;; should be modified according to the development required and
+;; `application-version` should be bumped. If the schema needs modification
+;; across time, those should be changed directly in the full-schema and the
+;; incremental changes should be referenced as migration step below for the
+;; new `application-version` (for the existing dbs to know what to migrate).
+(define schema-full
+  "
+create table if not exists SchemaVersion (
+  version integer primary key not null,
+  date date,
+  unique (version)
+);
+
+create table if not exists Packages (
+  id        integer primary key autoincrement not null,
+  name      text not null,
+  version   text not null,
+  unique    (name, version) -- add uniqueness constraint
+);
+
+create table if not exists Directories (
+  id        integer primary key autoincrement not null,
+  name      text not null,
+  package   integer not null,
+  foreign key (package) references Packages(id) on delete cascade,
+  unique (name, package) -- add uniqueness constraint
+);
+
+create table if not exists Files (
+  name      text not null,
+  basename  text not null,
+  directory integer not null,
+  foreign key (directory) references Directories(id) on delete cascade
+  unique (name, basename, directory) -- add uniqueness constraint
+);
+
+create index if not exists IndexFiles on Files(basename);")
+
+;; List of tuple ((version . sqlite schema migration script)). There should be
+;; as much version increments as step needed to migrate the db.
+(define schema-to-migrate '((1 . "
+create table if not exists SchemaVersion (
+  version integer primary key not null,
+  unique (version)
+);
+")
+                            (2 . "
+alter table SchemaVersion
+add column date date;
+")))
+
+(define (call-with-database file proc)
+  (let ((db (sqlite-open file)))
+    (dynamic-wind
+      (lambda () #t)
+      (lambda () (proc db))
+      (lambda () (sqlite-close db)))))
+
+(define (insert-version db version)
+  "Insert application VERSION into the DB."
+  (define stmt-insert-version
+    (sqlite-prepare db "\
+INSERT OR IGNORE INTO SchemaVersion(version, date)
+VALUES (:version, CURRENT_TIMESTAMP);"
+                    #:cache? #t))
+  (sqlite-exec db "begin immediate;")
+  (sqlite-bind-arguments stmt-insert-version #:version version)
+  (sqlite-fold (const #t) #t stmt-insert-version)
+  (sqlite-exec db "commit;"))
+
+(define (read-version db)
+  "Read the current application version from the DB."
+
+  (define stmt-select-version (sqlite-prepare db "\
+SELECT version FROM SchemaVersion ORDER BY version DESC LIMIT 1;"
+                                              #:cache? #f))
+  (match (sqlite-fold cons '() stmt-select-version)
+    ((#(version))
+     version)))
+
+(define (insert-files db package version directories)
+    "Insert files from DIRECTORIES as belonging to PACKAGE at VERSION."
+    (define stmt-select-package
+      (sqlite-prepare db "\
+SELECT id FROM Packages WHERE name = :name AND version = :version;"
+                      #:cache? #t))
+
+    (define stmt-insert-package
+      (sqlite-prepare db "\
+INSERT OR IGNORE INTO Packages(name, version) -- to avoid spurious writes
+VALUES (:name, :version);"
+                      #:cache? #t))
+
+    (define stmt-select-directory
+      (sqlite-prepare db "\
+SELECT id FROM Directories WHERE name = :name AND package = :package;"
+                      #:cache? #t))
+
+    (define stmt-insert-directory
+      (sqlite-prepare db "\
+INSERT OR IGNORE INTO Directories(name, package) -- to avoid spurious writes
+VALUES (:name, :package);"
+                      #:cache? #t))
+
+    (define stmt-insert-file
+      (sqlite-prepare db "\
+INSERT OR IGNORE INTO Files(name, basename, directory)
+VALUES (:name, :basename, :directory);"
+                      #:cache? #t))
+
+    (sqlite-exec db "begin immediate;")
+    (sqlite-bind-arguments stmt-insert-package
+                           #:name package
+                           #:version version)
+    (sqlite-fold (const #t) #t stmt-insert-package)
+
+    (sqlite-bind-arguments stmt-select-package
+                           #:name package
+                           #:version version)
+    (match (sqlite-fold cons '() stmt-select-package)
+      ((#(package-id))
+       (when debug
+         (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)"
+                 package version package-id)
+         (pk 'package package-id package))
+       (for-each (lambda (directory)
+                   (define (strip file)
+                     (string-drop file (+ (string-length directory) 1)))
+
+                   (sqlite-reset stmt-insert-directory)
+                   (sqlite-bind-arguments stmt-insert-directory
+                                          #:name directory
+                                          #:package package-id)
+                   (sqlite-fold (const #t) #t stmt-insert-directory)
+
+                   (sqlite-reset stmt-select-directory)
+                   (sqlite-bind-arguments stmt-select-directory
+                                          #:name directory
+                                          #:package package-id)
+                   (match (sqlite-fold cons '() stmt-select-directory)
+                     ((#(directory-id))
+                      (when debug
+                        (format #t "(name, package, dir-id): (~a, ~a, ~a)\n"
+                                directory package-id directory-id))
+                      (for-each (lambda (file)
+                                  ;; If DIRECTORY is a symlink, (find-files
+                                  ;; DIRECTORY) returns the DIRECTORY singleton.
+                                  (unless (string=? file directory)
+                                    (sqlite-reset stmt-insert-file)
+                                    (sqlite-bind-arguments stmt-insert-file
+                                                           #:name (strip file)
+                                                           #:basename
+                                                           (basename file)
+                                                           #:directory
+                                                           directory-id)
+                                    (sqlite-fold (const #t) #t stmt-insert-file)))
+                                (find-files directory)))))
+                 directories)))
+    (sqlite-exec db "commit;"))
+
+
+;;;
+;;; Indexing from local packages.
+;;;
+
+(define (insert-package db package)
+  "Insert all the files of PACKAGE into DB."
+  (mlet %store-monad ((drv (package->derivation package #:graft? #f)))
+    (match (derivation->output-paths drv)
+      (((labels . directories) ...)
+       (when (every file-exists? directories)
+         (insert-files db (package-name package) (package-version package)
+                       directories))
+       (return #t)))))
+
+(define (insert-packages-with-progress db packages insert-package-fn)
+  "Insert PACKAGES into DB with progress bar report."
+  (let* ((nb-packages (length packages))
+         (prefix      (format #f "Registering ~a packages" nb-packages))
+         (progress    (progress-reporter/bar nb-packages prefix)))
+    (call-with-progress-reporter progress
+      (lambda (report)
+        (for-each (lambda (package)
+                    (insert-package-fn db package)
+                    (report))
+                  packages)))))
+
+
+;;;
+;;; Indexing from local profiles.
+;;;
+
+(define (all-profiles)
+  "Return the list of system profiles."
+  (delete-duplicates
+   (filter-map (lambda (root)
+                 (if (file-exists? (string-append root "/manifest"))
+                     root
+                     (let ((root (string-append root "/profile")))
+                       (and (file-exists? (string-append root "/manifest"))
+                            root))))
+               (gc-roots))))
+
+(define (profiles->manifest-entries profiles)
+  "Return deduplicated manifest entries across all PROFILES."
+  (let loop ((visited (set))
+             (profiles profiles)
+             (entries '()))
+    (match profiles
+      (()
+       entries)
+      ((profile . rest)
+       (let* ((manifest (profile-manifest profile))
+              (entries visited
+                       (fold2 (lambda (entry lst visited)
+                                (let ((item (manifest-entry-item entry)))
+                                  (if (set-contains? visited item)
+                                      (values lst visited)
+                                      (values (cons entry lst)
+                                              (set-insert item
+                                                          visited)))))
+                              entries
+                              visited
+                              (manifest-transitive-entries manifest))))
+         (loop visited rest entries))))))
+
+(define (insert-manifest-entry db entry)
+  "Insert a manifest ENTRY into DB."
+  (insert-files db (manifest-entry-name entry)
+                (manifest-entry-version entry)
+                (list (manifest-entry-item entry)))) ;FIXME: outputs?
+
+(define (index-packages-from-manifests-with-db db-pathname)
+  "Index packages entries into DB-PATHNAME from the system manifests."
+  (call-with-database db-pathname
+    (lambda (db)
+      (let ((entries (profiles->manifest-entries (all-profiles))))
+        (insert-packages-with-progress db entries insert-manifest-entry)))))
+
+
+;;;
+;;; Search.
+;;;
+
+(define-record-type <package-match>
+  (package-match name version file)
+  package-match?
+  (name      package-match-name)
+  (version   package-match-version)
+  (file      package-match-file))
+
+(define (matching-packages db file)
+  "Return unique <package-match> corresponding to packages containing FILE."
+  (define lookup-stmt
+    (sqlite-prepare db "\
+SELECT Packages.name, Packages.version, Directories.name, Files.name
+FROM Packages
+INNER JOIN Files, Directories
+ON files.basename = :file
+  AND directories.id = files.directory
+  AND packages.id = directories.package;"))
+
+  (sqlite-bind-arguments lookup-stmt #:file file)
+  (sqlite-fold (lambda (result lst)
+                 (match result
+                   (#(package version directory file)
+                    (cons (package-match package version
+                                         (string-append directory "/" file))
+                          lst))))
+               '() lookup-stmt))
+
+
+
+;;;
+;;; CLI
+;;;
+
+(define (index-packages-from-store-with-db db-pathname)
+  "Index local store packages using db at location DB-PATHNAME."
+  (call-with-database db-pathname
+    (lambda (db)
+      (with-store store
+        (parameterize ((%graft? #f))
+          (define (insert-package-from-store db package)
+            (run-with-store store (insert-package db package)))
+          (let ((packages (fold-packages
+                           cons
+                           '()
+                           #:select? (lambda (package)
+                                       (and (not (hidden-package? package))
+                                            (not (package-superseded package))
+                                            (supported-package? package))))))
+            (insert-packages-with-progress
+             db packages insert-package-from-store))))
+      (index-packages-from-store db))))
+
+(define (matching-packages-with-db db-pathname file)
+  "Compute list of packages referencing FILE using db at DB-PATHNAME."
+  (call-with-database db-pathname
+    (lambda (db)
+      (matching-packages db file))))
+
+(define (read-version-from-db db-pathname)
+  (call-with-database db-pathname
+    (lambda (db) (read-version db))))
+
+(define (migrate-schema-to-version db-pathname)
+  (call-with-database db-pathname
+    (lambda (db)
+      (catch #t
+        (lambda ()
+          ;; Migrate from the current version to the full migrated schema
+          ;; This can raise sqlite-error if the db is not properly configured yet
+          (let* ((current-db-version (read-version db))
+                 (next-db-version (+ 1 current-db-version)))
+            (when (< current-db-version application-version)
+              ;; when the current db version is older than the current application
+              (let ((schema-migration-at-version (assoc-ref schema-to-migrate next-db-version)))
+                (when schema-migration-at-version
+                  ;; migrate the schema to the next version (if it exists)
+                  (sqlite-exec db schema-migration-at-version)
+                  ;; insert current version
+                  (insert-version db next-db-version)
+                  ;; iterate over the next migration if any
+                  (migrate-schema-to-version db))))))
+        (lambda (key . arg)
+          ;; exception handler in case failure to read an inexisting db
+          ;; Fallback to boostrap the schema
+          (sqlite-exec db schema-full)
+          (insert-version db application-version))))))
+
+(define (print-matching-results matches)
+  "Print the MATCHES matching results."
+  (for-each (lambda (result)
+              (format #t "~20a ~a~%"
+                      (string-append (package-match-name result)
+                                     "@" (package-match-version result))
+                      (package-match-file result)))
+            matches))
+
+(define default-db-path
+  (string-append (cache-directory #:ensure? #f)
+                 "/index/db.sqlite"))
+
+(define (show-help)
+  (display (G_ "Usage: guix index [OPTIONS...] [search FILE...]
+Without argument, indexes (package, file) relationships from the machine.
+This allows indexation with 2 methods, out of the local:
+
+- manifests: This is the fastest implementation with the caveat of indexing
+less packages. That'd be typically the use case of user local indexation.
+
+- store: This is slowest implementation. It discusses with the store
+daemon. That'd be typically the use case of building the largest db in one of
+the build farm node.
+
+With 'search FILE', search for packages installing FILE.\n
+Note: Internal cache is located at ~/.cache/guix/index/db.sqlite by default.
+See --db-path for customization.\n"))
+  (newline)
+  (display (G_ "The valid values for OPTIONS are:"))
+  (newline)
+  (display (G_ "
+  -h, --help          Display this help and exit"))
+  (display (G_ "
+  -V, --version       Display version information and exit"))
+  (display (G_ "
+  --db-path=DIR       Change default location of the cache db"))
+  (newline)
+  (display (G_ "
+  --method=METH       Change default indexation method. By default it uses the
+                      local \"manifests\" (faster). It can also uses the local
+                      \"store\" (slower, typically on the farm build ci)."))
+  (newline)
+  (display (G_ "The valid values for ARGS are:"))
+  (newline)
+  (display (G_ "
+  search FILE     Search for packages installing the FILE (from cache db)"))
+  (newline)
+  (display (G_ "
+  <EMPTY>         Without any argument, it index packages. This fills in the
+                  db cache using whatever indexation method is defined."))
+  (show-bug-report-information))
+
+(define %options
+  (list
+   (option '(#\h "help") #f #f
+           (lambda args (show-help) (exit 0)))
+   (option '(#\V "version") #f #f
+           (lambda (opt name arg result)
+             (catch 'sqlite-error
+               (lambda ()
+                 (let ((db-path (assoc-ref result 'db-path)))
+                   (simple-format
+                    #t
+                    "Extension local cache database:\n- path: ~a\n- version: ~a\n\n"
+                    db-path (read-version-from-db db-path))))
+               (lambda (key . arg) 'no-db-yet-so-nothing-to-display))
+             (show-version-and-exit "guix index")))
+   ;; index data out of the method (store or package)
+   (option '(#\d "db-path") #f #t
+           (lambda (opt name arg result)
+             (when debug
+               (format #t "%options: --db-path: opt ~a\n" opt)
+               (format #t "%options: --db-path: name ~a\n" name)
+               (format #t "%options: --db-path: arg ~a\n" arg)
+               (format #t "%options: --db-path: result ~a\n" result))
+             (alist-cons 'db-path arg
+                         (alist-delete 'db-path result))))
+
+   ;; index data out of the method (store or package)
+   (option '(#\m "method") #f #t
+           (lambda (opt name arg result)
+             (when debug
+               (format #t "%options: --method: opt ~a\n" opt)
+               (format #t "%options: --method: name ~a\n" name)
+               (format #t "%options: --method: arg ~a\n" arg)
+               (format #t "%options: --method: result ~a\n" result))
+             (match arg
+               ((or "manifests" "store")
+                (alist-cons 'with-method arg
+                            (alist-delete 'with-method result)))
+               (_
+                (G_ "guix index: Wrong indexation method, either manifests
+ (fast) or store (slow)~%")))))))
+
+(define %default-options
+  `((db-path . ,default-db-path)
+    (with-method . "manifests")))
+
+(define-command (guix-index . args)
+  (category extension)
+  (synopsis "Index packages to search package for a given filename")
+
+  (define (parse-sub-command arg result)
+    ;; Parse sub-command ARG and augment RESULT accordingly.
+    (when debug
+      (format #t "parse-sub-command: arg: ~a\n" arg)
+      (format #t "parse-sub-command: result: ~a\n" result)
+      (format #t "parse-sub-command: (assoc-ref result 'action): ~a\n" (assoc-ref result 'action))
+      (format #t "parse-sub-command: (assoc-ref result 'argument): ~a\n" (assoc-ref result 'argument)))
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (let ((action (string->symbol arg)))
+          (case action
+            ((search)
+             (alist-cons 'action action result))
+            (else (leave (G_ "~a: unknown action~%") action))))))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (define (option-arguments opts)
+    ;; Extract the plain arguments from OPTS.
+    (let* ((args   (reverse (filter-map (match-pair 'argument) opts)))
+           (count  (length args))
+           (action (or (assoc-ref opts 'action) 'index)))
+
+      (when debug
+        (format #t "option-arguments: args: ~a\n" args)
+        (format #t "option-arguments: count: ~a\n" count)
+        (format #t "option-arguments: action: ~a\n" action))
+
+      (define (fail)
+        (leave (G_ "wrong number of arguments for action '~a'~%")
+               action))
+
+      (unless action
+        (format (current-error-port)
+                (G_ "guix index: missing command name~%"))
+        (format (current-error-port)
+                (G_ "Try 'guix index --help' for more information.~%"))
+        (exit 1))
+      (alist-cons 'argument (string-concatenate args)
+                  (alist-delete 'argument
+                                (alist-cons 'action action
+                                            (alist-delete 'action opts))))))
+
+  (with-error-handling
+    (let* ((opts        (parse-command-line args %options
+                                            (list %default-options)
+                                            #:argument-handler
+                                            parse-sub-command))
+           (args        (option-arguments opts))
+           (action      (assoc-ref args 'action))
+           (db-path     (assoc-ref args 'db-path))
+           (with-method (assoc-ref args 'with-method)))
+      (when debug
+        (format #t "main: opts: ~a\n" opts)
+        (format #t "main: args: ~a\n" args)
+        (format #t "main: action: ~a\n" action)
+        (format #t "main: db-path: ~a\n" db-path)
+        (format #t "main: with-method: ~a\n" with-method))
+
+      (match action
+        ('search
+         (unless (file-exists? db-path)
+           (format (current-error-port)
+                   (G_ "guix index: The local cache db does not exist yet.
+You need to index packages first.\nTry 'guix index --help' for more information.~%"))
+           (exit 1))
+         (let* ((file (assoc-ref args 'argument))
+                (matches (matching-packages-with-db db-path file)))
+           (print-matching-results matches)
+           (exit (pair? matches))))
+        ('index
+         (let ((db-dirpath (dirname db-path)))
+           (unless (file-exists? db-dirpath)
+             (mkdir db-dirpath)))
+         ;; Migrate/initialize db to schema at version application-version
+         (migrate-schema-to-version db-path)
+         ;; Finally index packages
+         (if (string= with-method "manifests")
+             (index-packages-from-manifests-with-db db-path)
+             (index-packages-from-store-with-db db-path)))))))
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 8ff8182a79..9a6ddae271 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -69,7 +69,7 @@ (define-module (guix scripts home)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-35)
-  #:use-module (srfi srfi-37)
+  #:use-module ((srfi srfi-37) #:select (option))
   #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:export (guix-home))
-- 
2.36.1

From 434b27de6227f5077505c1a1688a6ae500bbe56f Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <[email-masked]>
Date: Tue, 20 Dec 2022 16:05:50 +0100
Subject: [PATCH core-updates 2/6] scripts-index: Transform `guix index`
 extension into a Guix script

---
 guix/{extensions => scripts}/index.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)
 rename guix/{extensions => scripts}/index.scm (99%)

diff --git a/guix/extensions/index.scm b/guix/scripts/index.scm
similarity index 99%
rename from guix/extensions/index.scm
rename to guix/scripts/index.scm
index d9894b213e..8d68a63847 100644
--- a/guix/extensions/index.scm
+++ b/guix/scripts/index.scm
@@ -16,7 +16,7 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(define-module (guix extensions index)
+(define-module (guix scripts index)
   #:use-module ((guix i18n) #:select (G_))
   #:use-module ((guix ui) #:select (show-version-and-exit
                                     show-bug-report-information
@@ -484,7 +484,7 @@ (define %default-options
     (with-method . "manifests")))
 
 (define-command (guix-index . args)
-  (category extension)
+  (category packaging)
   (synopsis "Index packages to search package for a given filename")
 
   (define (parse-sub-command arg result)
-- 
2.36.1

From 8799fcfb9f6238abe0e19ce650ee7f1e2b7e0d90 Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <[email-masked]>
Date: Thu, 22 Dec 2022 15:53:43 +0100
Subject: [PATCH core-updates 3/6] scripts-index: Store outputs alongside
 packages

---
 guix/scripts/index.scm | 207 ++++++++++++++++++++++-------------------
 1 file changed, 112 insertions(+), 95 deletions(-)

diff --git a/guix/scripts/index.scm b/guix/scripts/index.scm
index 8d68a63847..d1478042ab 100644
--- a/guix/scripts/index.scm
+++ b/guix/scripts/index.scm
@@ -50,7 +50,7 @@ (define-module (guix scripts index)
 
 (define debug #f)
 
-(define application-version 2)
+(define application-version 3)
 
 ;; The following schema is the full schema at the `application-version`.  It
 ;; should be modified according to the development required and
@@ -70,6 +70,7 @@ (define schema-full
   id        integer primary key autoincrement not null,
   name      text not null,
   version   text not null,
+  output    text,
   unique    (name, version) -- add uniqueness constraint
 );
 
@@ -102,6 +103,10 @@ (define schema-to-migrate '((1 . "
                             (2 . "
 alter table SchemaVersion
 add column date date;
+")
+                            (3 . "
+alter table Packages
+add column output text;
 ")))
 
 (define (call-with-database file proc)
@@ -133,85 +138,90 @@ (define stmt-select-version (sqlite-prepare db "\
     ((#(version))
      version)))
 
-(define (insert-files db package version directories)
-    "Insert files from DIRECTORIES as belonging to PACKAGE at VERSION."
-    (define stmt-select-package
-      (sqlite-prepare db "\
-SELECT id FROM Packages WHERE name = :name AND version = :version;"
-                      #:cache? #t))
-
-    (define stmt-insert-package
-      (sqlite-prepare db "\
-INSERT OR IGNORE INTO Packages(name, version) -- to avoid spurious writes
-VALUES (:name, :version);"
-                      #:cache? #t))
-
-    (define stmt-select-directory
-      (sqlite-prepare db "\
+(define (insert-files db package version outputs directories)
+  "Insert DIRECTORIES files belonging to VERSION PACKAGE (with OUTPUTS)."
+  (define stmt-select-package
+    (sqlite-prepare db "\
+SELECT id FROM Packages WHERE name = :name AND version = :version LIMIT 1;"
+                    #:cache? #t))
+
+  (define stmt-insert-package
+    (sqlite-prepare db "\
+INSERT OR REPLACE INTO Packages(name, version, output)
+VALUES (:name, :version, :output);"
+                    #:cache? #t))
+
+  (define stmt-select-directory
+    (sqlite-prepare db "\
 SELECT id FROM Directories WHERE name = :name AND package = :package;"
-                      #:cache? #t))
+                    #:cache? #t))
 
-    (define stmt-insert-directory
-      (sqlite-prepare db "\
+  (define stmt-insert-directory
+    (sqlite-prepare db "\
 INSERT OR IGNORE INTO Directories(name, package) -- to avoid spurious writes
 VALUES (:name, :package);"
-                      #:cache? #t))
+                    #:cache? #t))
 
-    (define stmt-insert-file
-      (sqlite-prepare db "\
+  (define stmt-insert-file
+    (sqlite-prepare db "\
 INSERT OR IGNORE INTO Files(name, basename, directory)
 VALUES (:name, :basename, :directory);"
-                      #:cache? #t))
-
-    (sqlite-exec db "begin immediate;")
-    (sqlite-bind-arguments stmt-insert-package
-                           #:name package
-                           #:version version)
-    (sqlite-fold (const #t) #t stmt-insert-package)
-
-    (sqlite-bind-arguments stmt-select-package
-                           #:name package
-                           #:version version)
-    (match (sqlite-fold cons '() stmt-select-package)
-      ((#(package-id))
-       (when debug
-         (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)"
-                 package version package-id)
-         (pk 'package package-id package))
-       (for-each (lambda (directory)
-                   (define (strip file)
-                     (string-drop file (+ (string-length directory) 1)))
-
-                   (sqlite-reset stmt-insert-directory)
-                   (sqlite-bind-arguments stmt-insert-directory
-                                          #:name directory
-                                          #:package package-id)
-                   (sqlite-fold (const #t) #t stmt-insert-directory)
-
-                   (sqlite-reset stmt-select-directory)
-                   (sqlite-bind-arguments stmt-select-directory
-                                          #:name directory
-                                          #:package package-id)
-                   (match (sqlite-fold cons '() stmt-select-directory)
-                     ((#(directory-id))
-                      (when debug
-                        (format #t "(name, package, dir-id): (~a, ~a, ~a)\n"
-                                directory package-id directory-id))
-                      (for-each (lambda (file)
-                                  ;; If DIRECTORY is a symlink, (find-files
-                                  ;; DIRECTORY) returns the DIRECTORY singleton.
-                                  (unless (string=? file directory)
-                                    (sqlite-reset stmt-insert-file)
-                                    (sqlite-bind-arguments stmt-insert-file
-                                                           #:name (strip file)
-                                                           #:basename
-                                                           (basename file)
-                                                           #:directory
-                                                           directory-id)
-                                    (sqlite-fold (const #t) #t stmt-insert-file)))
-                                (find-files directory)))))
-                 directories)))
-    (sqlite-exec db "commit;"))
+                    #:cache? #t))
+
+  (sqlite-exec db "begin immediate;")
+  ;; 1 record per output
+  (for-each (lambda (output)
+              (let ((out (if (string=? "out" output) "" output)))
+                (sqlite-reset stmt-insert-package)
+                (sqlite-bind-arguments stmt-insert-package
+                                       #:name package
+                                       #:version version
+                                       #:output out)
+                (sqlite-fold (const #t) #t stmt-insert-package)))
+            outputs)
+  (sqlite-bind-arguments stmt-select-package
+                         #:name package
+                         #:version version)
+  (match (sqlite-fold cons '() stmt-select-package)
+    ((#(package-id))
+     (when debug
+       (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)"
+               package version package-id)
+       (pk 'package package-id package))
+     (for-each (lambda (directory)
+                 (define (strip file)
+                   (string-drop file (+ (string-length directory) 1)))
+
+                 (sqlite-reset stmt-insert-directory)
+                 (sqlite-bind-arguments stmt-insert-directory
+                                        #:name directory
+                                        #:package package-id)
+                 (sqlite-fold (const #t) #t stmt-insert-directory)
+
+                 (sqlite-reset stmt-select-directory)
+                 (sqlite-bind-arguments stmt-select-directory
+                                        #:name directory
+                                        #:package package-id)
+                 (match (sqlite-fold cons '() stmt-select-directory)
+                   ((#(directory-id))
+                    (when debug
+                      (format #t "(name, package, dir-id): (~a, ~a, ~a)\n"
+                              directory package-id directory-id))
+                    (for-each (lambda (file)
+                                ;; If DIRECTORY is a symlink, (find-files
+                                ;; DIRECTORY) returns the DIRECTORY singleton.
+                                (unless (string=? file directory)
+                                  (sqlite-reset stmt-insert-file)
+                                  (sqlite-bind-arguments stmt-insert-file
+                                                         #:name (strip file)
+                                                         #:basename
+                                                         (basename file)
+                                                         #:directory
+                                                         directory-id)
+                                  (sqlite-fold (const #t) #t stmt-insert-file)))
+                              (find-files directory)))))
+               directories)))
+  (sqlite-exec db "commit;"))
 
 
 ;;;
@@ -224,8 +234,9 @@ (define (insert-package db package)
     (match (derivation->output-paths drv)
       (((labels . directories) ...)
        (when (every file-exists? directories)
-         (insert-files db (package-name package) (package-version package)
-                       directories))
+         (insert-files
+          db (package-name package) (package-version package) (package-outputs package)
+          directories))
        (return #t)))))
 
 (define (insert-packages-with-progress db packages insert-package-fn)
@@ -283,6 +294,7 @@ (define (insert-manifest-entry db entry)
   "Insert a manifest ENTRY into DB."
   (insert-files db (manifest-entry-name entry)
                 (manifest-entry-version entry)
+                (list (manifest-entry-output entry))
                 (list (manifest-entry-item entry)))) ;FIXME: outputs?
 
 (define (index-packages-from-manifests-with-db db-pathname)
@@ -298,28 +310,29 @@ (define (index-packages-from-manifests-with-db db-pathname)
 ;;;
 
 (define-record-type <package-match>
-  (package-match name version file)
+  (package-match name version output file)
   package-match?
-  (name      package-match-name)
-  (version   package-match-version)
-  (file      package-match-file))
+  (name    package-match-name)
+  (version package-match-version)
+  (output  package-match-output)
+  (file    package-match-file))
 
 (define (matching-packages db file)
   "Return unique <package-match> corresponding to packages containing FILE."
   (define lookup-stmt
     (sqlite-prepare db "\
-SELECT Packages.name, Packages.version, Directories.name, Files.name
-FROM Packages
-INNER JOIN Files, Directories
-ON files.basename = :file
-  AND directories.id = files.directory
-  AND packages.id = directories.package;"))
+SELECT p.name, p.version, p.output, d.name, f.name
+FROM Packages p
+INNER JOIN Files f, Directories d
+ON f.basename = :file
+  AND d.id = f.directory
+  AND p.id = d.package;"))
 
   (sqlite-bind-arguments lookup-stmt #:file file)
   (sqlite-fold (lambda (result lst)
                  (match result
-                   (#(package version directory file)
-                    (cons (package-match package version
+                   (#(package version output directory file)
+                    (cons (package-match package version output
                                          (string-append directory "/" file))
                           lst))))
                '() lookup-stmt))
@@ -346,14 +359,12 @@ (define (insert-package-from-store db package)
                                             (not (package-superseded package))
                                             (supported-package? package))))))
             (insert-packages-with-progress
-             db packages insert-package-from-store))))
-      (index-packages-from-store db))))
+             db packages insert-package-from-store)))))))
 
 (define (matching-packages-with-db db-pathname file)
   "Compute list of packages referencing FILE using db at DB-PATHNAME."
   (call-with-database db-pathname
-    (lambda (db)
-      (matching-packages db file))))
+    (lambda (db) (matching-packages db file))))
 
 (define (read-version-from-db db-pathname)
   (call-with-database db-pathname
@@ -387,10 +398,16 @@ (define (migrate-schema-to-version db-pathname)
 (define (print-matching-results matches)
   "Print the MATCHES matching results."
   (for-each (lambda (result)
-              (format #t "~20a ~a~%"
-                      (string-append (package-match-name result)
-                                     "@" (package-match-version result))
-                      (package-match-file result)))
+              (let ((name    (package-match-name result))
+                    (version (package-match-version result))
+                    (output  (package-match-output result))
+                    (file    (package-match-file result)))
+                (format #t "~20a ~a~%"
+                        (string-append name "@" version
+                                       (if (string-null? output)
+                                           ""
+                                           (string-append ":" output)))
+                        file)))
             matches))
 
 (define default-db-path
-- 
2.36.1

From ecea57fd4b46a8da5b78db17ceb7d8225a9e68e6 Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <[email-masked]>
Date: Fri, 24 Feb 2023 13:54:05 +0100
Subject: [PATCH core-updates 4/6] Makefile.am: Reference new script to compile

---
 Makefile.am | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/Makefile.am b/Makefile.am
index 23b939b674..6edd5eb900 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -302,6 +302,7 @@ MODULES =					\
   guix/scripts/archive.scm			\
   guix/scripts/import.scm			\
   guix/scripts/package.scm			\
+  guix/scripts/index.scm			\
   guix/scripts/install.scm			\
   guix/scripts/remove.scm			\
   guix/scripts/upgrade.scm			\
@@ -589,6 +590,7 @@ SH_TESTS =					\
   tests/guix-gc.sh				\
   tests/guix-git-authenticate.sh		\
   tests/guix-hash.sh				\
+  tests/guix-index.sh				\
   tests/guix-pack.sh				\
   tests/guix-pack-localstatedir.sh		\
   tests/guix-pack-relocatable.sh		\
-- 
2.36.1

From ae756e5add599fe0bb07547b5ff43ffa22f47da0 Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <[email-masked]>
Date: Fri, 24 Feb 2023 13:54:17 +0100
Subject: [PATCH core-updates 5/6] Bootstrap tests for guix index subcommand

---
 guix/scripts/index.scm |  4 +++
 tests/guix-index.sh    | 73 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 77 insertions(+)
 create mode 100755 tests/guix-index.sh

diff --git a/guix/scripts/index.scm b/guix/scripts/index.scm
index d1478042ab..adf0f31269 100644
--- a/guix/scripts/index.scm
+++ b/guix/scripts/index.scm
@@ -555,6 +555,10 @@ (define (fail)
   (with-error-handling
     (let* ((opts        (parse-command-line args %options
                                             (list %default-options)
+                                            ;; ignore $GUIX_BUILD_OPTIONS
+                                            ;; otherwise, subcommand is not
+                                            ;; detected in the tests context
+                                            #:build-options? #f
                                             #:argument-handler
                                             parse-sub-command))
            (args        (option-arguments opts))
diff --git a/tests/guix-index.sh b/tests/guix-index.sh
new file mode 100755
index 0000000000..2c21d45a6b
--- /dev/null
+++ b/tests/guix-index.sh
@@ -0,0 +1,73 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2013, 2014, 2015, 2019, 2020, 2023 Ludovic Courtès <[email-masked]>
+#
+# This file is part of GNU Guix.
+#
+# GNU Guix is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or (at
+# your option) any later version.
+#
+# GNU Guix is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+#
+# Test the 'guix index' command-line utility.
+#
+
+set -x
+
+tmpdir="guix-index-$$"
+trap 'rm -rf "$tmpdir"' EXIT
+
+guix index --version
+
+# Basic application to install and lookup through the index subcommand
+APPLICATION=guile-bootstrap
+
+# The subcommand exposes two indexation methods so far:
+# - manifests: fast and less exhaustive
+# - store: slow, exhaustive
+
+# In the following tests, we will store in 2 different dbs for both indexation
+# methods
+tmpdb_manifests="$tmpdir/manifests/db.sqlite"
+tmpdb_store="$tmpdir/store/db.sqlite"
+
+echo "### Preparing db locations for both indexation methods"
+mkdir -p `dirname $tmpdb_manifests` `dirname $tmpdb_store`
+
+cmd_manifests="guix index --db-path=$tmpdb_manifests --method=manifests"
+cmd_store="guix index --db-path=$tmpdb_store --method=store"
+
+echo "### Lookup without any db should fail"
+! $cmd_manifests search "$APPLICATION"
+! $cmd_store search "$APPLICATION"
+
+echo "### Initializing db with bare guix store should work"
+$cmd_manifests
+# ! $cmd_store
+
+echo "### lookup without anything in db should yield no result"
+! test `$cmd_manifests search "$APPLICATION"`
+# ! test `$cmd_store search "$APPLICATION"`
+
+echo "### Add some package to the temporary store"
+guix package --bootstrap \
+     --install $APPLICATION \
+     --profile=$tmpdir/profile
+
+echo "### Both both indexation call should work"
+# Testing indexation should work for both method
+test `$cmd_manifests`
+# test `$cmd_store`
+
+echo "### lookup indexed '$APPLICATION' should yield result"
+
+test `$cmd_manifests search "$APPLICATION"`
+# test `$cmd_store search "$APPLICATION"`
-- 
2.36.1

From 372b2b9660b8293eebd6280bb46a4ec07d4192a7 Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <[email-masked]>
Date: Mon, 13 Mar 2023 13:52:38 +0100
Subject: [PATCH core-updates 6/6] Allow gcroot function to exceptionally
 ignore error
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Co-authored with Ludovic Courtès <[email-masked]>
---
 guix/store/roots.scm  | 10 +++++++++-
 tests/store-roots.scm |  7 ++++++-
 2 files changed, 15 insertions(+), 2 deletions(-)

diff --git a/guix/store/roots.scm b/guix/store/roots.scm
index 222f69c5c0..c2b15c33f0 100644
--- a/guix/store/roots.scm
+++ b/guix/store/roots.scm
@@ -105,7 +105,15 @@ (define canonical-root
                                      (map (match-lambda
                                             ((file . properties)
                                              (cons (scope file) properties)))
-                                          (scandir* directory regular?)))))
+                                          (catch 'system-error
+                                            (lambda ()
+                                              (scandir* directory regular?))
+                                            (lambda args
+                                              (if (= ENOENT
+                                                     (system-error-errno
+                                                      args))
+                                                  '()
+                                                  (apply throw args))))))))
              (loop (append rest (map first sub-directories))
                    (append (map canonical-root (filter symlink? files))
                            roots)
diff --git a/tests/store-roots.scm b/tests/store-roots.scm
index 5bcf1bc87e..00a4fe7931 100644
--- a/tests/store-roots.scm
+++ b/tests/store-roots.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2019, 2023 Ludovic Courtès <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +21,7 @@ (define-module (test-store-deduplication)
   #:use-module (guix store)
   #:use-module (guix store roots)
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
+  #:use-module ((guix config) #:select (%state-directory))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64))
 
@@ -29,6 +30,10 @@ (define %store
 
 (test-begin "store-roots")
 
+(test-equal "gc-roots, initial"
+  (list (string-append %state-directory "/profiles"))
+  (gc-roots))
+
 (test-assert "gc-roots, regular root"
   (let* ((item (add-text-to-store %store "something"
                                   (random-text)))
-- 
2.36.1