Add 'guix locate'.

* guix/scripts/locate.scm, tests/guix-locate.sh: New files.
* Makefile.am (MODULES): Add 'guix/scripts/locate.scm'.
(SH_TESTS): Add 'tests/guix-locate.sh'.
* po/guix/POTFILES.in: Add it.
* doc/guix.texi (Invoking guix locate): New node.

Co-authored-by: Antoine R. Dumont <antoine.romain.dumont@gmail.com>

1 files changed, 659 insertions, 0 deletions

diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm
new file mode 100644
index 0000000000..aeaffa3d34
--- /dev/null
+++ b/guix/scripts/locate.scm
@@ -0,0 +1,659 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Antoine R. Dumont <antoine.romain.dumont@gmail.com>
+;;;
+;;; 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 scripts locate)
+  #:use-module ((guix config) #:select (%localstatedir))
+  #:use-module (guix i18n)
+  #:use-module ((guix ui)
+                #:select (show-version-and-exit
+                          show-bug-report-information
+                          with-error-handling
+                          string->number*
+                          display-hint
+                          leave-on-EPIPE))
+  #:use-module (guix diagnostics)
+  #:use-module (guix scripts)
+  #:use-module (sqlite3)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #: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)
+  #:autoload   (guix progress) (progress-reporter/bar
+                                call-with-progress-reporter)
+  #:use-module (guix sets)
+  #:use-module ((guix utils) #:select (cache-directory))
+  #:autoload   (guix build utils) (find-files mkdir-p)
+  #:autoload   (gnu packages) (fold-packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
+  #:export     (guix-locate))
+
+(define %db-schema-version
+  ;; Current database schema version.
+  3)
+
+;; The following schema is the full schema at the `%db-schema-version`.  It
+;; should be modified according to the development required and
+;; `%db-schema-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 `%db-schema-version` (for the existing dbs to know what to migrate).
+(define %db-schema
+  "
+create table if not exists SchemaVersion (
+  version integer primary key not null,
+  date    integer,
+  store   text not null,    -- value of (%store-prefix)
+  unique (version)
+);
+
+create table if not exists Packages (
+  id        integer primary key autoincrement not null,
+  name      text not null,
+  version   text not null,
+  output    text,
+  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;
+")
+                            (3 . "
+alter table Packages
+add column output text;
+")))
+
+(define (call-with-database file proc)
+  (let ((db (sqlite-open file)))
+    (dynamic-wind
+      (lambda () #t)
+      (lambda ()
+        (ensure-latest-database-schema db)
+        (proc db))
+      (lambda () (sqlite-close db)))))
+
+(define (ensure-latest-database-schema db)
+  "Ensure DB follows the latest known version of the schema."
+  (define (initialize)
+    (sqlite-exec db %db-schema)
+    (insert-version db %db-schema-version))
+
+  (let ((version (false-if-exception (read-version db))))
+    (cond ((not version)
+           (initialize))
+          ((> version %db-schema-version)
+           (initialize))
+          (else
+           (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 loop ((current version))
+                 (when (< current %db-schema-version)
+                   ;; when the current db version is older than the current application
+                   (let* ((next (+ current 1))
+                          (migration (assoc-ref schema-to-migrate next)))
+                     (when migration
+                       (sqlite-exec db migration)
+                       (insert-version db next))
+                     (loop next)))))
+             (lambda _
+               ;; Exception handler in case failure to read an inexisting db:
+               ;; fallback to bootstrap the schema.
+               (initialize)))))))
+
+(define (last-insert-row-id db)        ;XXX: copied from (guix store database)
+  ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
+  ;; Work around that.
+  (define stmt
+    (sqlite-prepare db "SELECT last_insert_rowid();"
+                    #:cache? #t))
+  (match (sqlite-fold cons '() stmt)
+    ((#(id)) id)
+    (_ #f)))
+
+(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, store)
+VALUES (:version, CURRENT_TIMESTAMP, :store);"
+                    #:cache? #t))
+  (sqlite-exec db "begin immediate;")
+  (sqlite-bind-arguments stmt-insert-version
+                         #:version version
+                         #:store (%store-prefix))
+  (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 user-database-file
+  ;; Default user database file name.
+  (string-append (cache-directory #:ensure? #f)
+                 "/locate/db.sqlite"))
+
+(define system-database-file
+  ;; System-wide database file name.
+  (string-append %localstatedir "/cache/guix/locate/db.sqlite"))
+
+(define (suitable-database create?)
+  "Return a suitable database file.  When CREATE? is true, the returned
+database will be opened for writing; otherwise, return the most recent one,
+user or system."
+  (if (zero? (getuid))
+      system-database-file
+      (if create?
+          user-database-file
+          (let ((system (stat system-database-file #f))
+                (user   (stat user-database-file #f)))
+            (if user
+                (if (and system (> (stat:mtime system) (stat:mtime user)))
+                    system-database-file
+                    user-database-file)
+                (if system
+                    system-database-file
+                    user-database-file))))))
+
+(define (clear-database db)
+  "Drop packages and files from DB."
+  (sqlite-exec db "BEGIN IMMEDIATE;")
+  (sqlite-exec db "DELETE FROM Files;")
+  (sqlite-exec db "DELETE FROM Directories;")
+  (sqlite-exec db "DELETE FROM Packages;")
+  (sqlite-exec db "COMMIT;")
+  (sqlite-exec db "VACUUM;"))
+
+(define (print-statistics file)
+  "Print statistics about the database in FILE."
+  (define (count db table)
+    (define stmt
+      (sqlite-prepare
+       db (string-append "SELECT COUNT(*) FROM " table ";")))
+
+    (match (sqlite-fold cons '() stmt)
+      ((#(number)) number)))
+
+  (call-with-database file
+    (lambda (db)
+      (format #t (G_ "schema version:\t~a~%")
+              (read-version db))
+      (format #t (G_ "number of packages:\t~9h~%")
+              (count db "Packages"))
+      (format #t (G_ "number of files:\t~9h~%")
+              (count db "Files"))
+      (format #t (G_ "database size:\t~9h MiB~%")
+              (inexact->exact
+               (round (/ (stat:size (stat file))
+                         (expt 2 20))))))))
+
+
+;;;
+;;; Indexing from local packages.
+;;;
+
+(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 IGNORE INTO Packages(name, version, output)
+VALUES (:name, :version, :output);"
+                    #:cache? #t))
+
+  (define stmt-select-directory
+    (sqlite-prepare db "\
+SELECT id FROM Directories WHERE 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;")
+  ;; 1 record per output
+  (for-each (lambda (output)
+              (sqlite-reset stmt-insert-package)
+              (sqlite-bind-arguments stmt-insert-package
+                                     #:name package
+                                     #:version version
+                                     #:output output)
+              (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))
+     (for-each (lambda (directory)
+                 (define (strip file)
+                   (string-drop file (+ (string-length directory) 1)))
+
+                 ;; If there's already a directory associated with PACKAGE-ID,
+                 ;; not necessarily the same directory, skip it.  That keeps
+                 ;; the database slimmer at the expense of not recording
+                 ;; variants of the same package; it also makes indexing
+                 ;; faster.
+                 (sqlite-reset stmt-select-directory)
+                 (sqlite-bind-arguments stmt-select-directory
+                                        #:package package-id)
+                 (when (null? (sqlite-fold cons '() stmt-select-directory))
+                   ;; DIRECTORY is missing so insert it and traverse it.
+                   (sqlite-reset stmt-insert-directory)
+                   (sqlite-bind-arguments stmt-insert-directory
+                                          #:name (store-path-base directory)
+                                          #:package package-id)
+                   (sqlite-fold (const #t) #t stmt-insert-directory)
+
+                   (let ((directory-id (last-insert-row-id db)))
+                     (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;"))
+
+(define (insert-package db package)
+  "Insert all the files of PACKAGE into DB."
+  (define stmt-select-package-output
+    (sqlite-prepare db "\
+SELECT output FROM Packages WHERE name = :name AND version = :version"
+                    #:cache? #t))
+
+  (define (known-outputs package)
+    ;; Return the list of outputs of PACKAGE already in DB.
+    (sqlite-bind-arguments stmt-select-package-output
+                           #:name (package-name package)
+                           #:version (package-version package))
+    (match (sqlite-fold cons '() stmt-select-package-output)
+      ((#(outputs ...)) outputs)
+      (() '())))
+
+  (with-monad %store-monad
+    ;; Since calling 'package->derivation' is expensive, do not call it if the
+    ;; outputs of PACKAGE at VERSION are already in DB.
+    (munless (lset= string=?
+                    (known-outputs package)
+                    (package-outputs package))
+      (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) (package-outputs package)
+              directories))
+           (return #t)))))))
+
+(define (insert-packages-with-progress db packages insert-package)
+  "Insert PACKAGES into DB with progress bar reporting, calling INSERT-PACKAGE
+for each package to insert."
+  (let* ((count    (length packages))
+         (prefix   (format #f (G_ "indexing ~h packages") count))
+         (progress (progress-reporter/bar count prefix)))
+    (call-with-progress-reporter progress
+      (lambda (report)
+        (for-each (lambda (package)
+                    (insert-package db package)
+                    (report))
+                  packages)))))
+
+(define (index-packages-from-store-with-db db)
+  "Index local store packages using 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)))))
+
+
+;;;
+;;; 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-output entry))
+                (list (manifest-entry-item entry)))) ;FIXME: outputs?
+
+(define (index-packages-from-manifests-with-db db)
+  "Index packages entries into DB from the system manifests."
+  (info (G_ "traversing local profile manifests...~%"))
+  (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 output file)
+  package-match?
+  (name    package-match-name)
+  (version package-match-version)
+  (output  package-match-output)
+  (file    package-match-file))
+
+(define* (matching-packages db file #:key glob?)
+  "Return a list of <package-match> records, one for each package containing
+FILE.  When GLOB? is true, interpret FILE as a glob pattern."
+  (define match-stmt
+    (if glob?
+        "f.basename GLOB :file"
+        "f.basename = :file"))
+
+  (define lookup-stmt
+    (sqlite-prepare db (string-append "\
+SELECT p.name, p.version, p.output, d.name, f.name
+FROM Packages p
+INNER JOIN Files f, Directories d
+ON " match-stmt "
+  AND d.id = f.directory
+  AND p.id = d.package;")))
+
+  (define prefix
+    (match (sqlite-fold (lambda (value _) value)
+                        #f
+                        (sqlite-prepare db "SELECT store FROM SchemaVersion;"))
+      (#(prefix) prefix)))
+
+  (sqlite-bind-arguments lookup-stmt #:file file)
+  (sqlite-fold (lambda (result lst)
+                 (match result
+                   (#(package version output directory file)
+                    (cons (package-match package version output
+                                         (string-append prefix "/"
+                                                        directory "/" file))
+                          lst))))
+               '() lookup-stmt))
+
+(define (print-matching-results matches)
+  "Print the MATCHES matching results."
+  (for-each (lambda (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
+                                       (match output
+                                         ("out" "")
+                                         (_ (string-append ":" output))))
+                        file)))
+            matches))
+
+
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (G_ "Usage: guix locate [OPTIONS...] FILE...
+Locate FILE and return the list of packages that contain it.\n"))
+  (display (G_ "
+  -g, --glob          interpret FILE as a glob pattern"))
+  (display (G_ "
+      --stats         display database statistics"))
+  (display (G_ "
+  -u, --update        force a database update"))
+  (display (G_ "
+      --clear         clear the database"))
+  (display (G_ "
+      --database=FILE store the database in FILE"))
+  (newline)
+  (display (G_ "
+      --method=METHOD use METHOD to select packages to index; METHOD can
+                      be 'manifests' (fast) or 'store' (slower)"))
+  (newline)
+  (display (G_ "
+  -h, --help          display this help and exit"))
+  (display (G_ "
+  -V, --version       display version information and exit"))
+  (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)
+                  (show-version-and-exit "guix locate")))
+        (option '(#\g "glob") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'glob? #t result)))
+        (option '("stats") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'stats? #t result)))
+        (option '("database") #f #t
+                (lambda (opt name arg result)
+                  (alist-cons 'database (const arg)
+                              (alist-delete 'database result))))
+        (option '(#\u "update") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'update? #t result)))
+        (option '("clear") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'clear? #t result)))
+        (option '(#\m "method") #f #t
+                (lambda (opt name arg result)
+                  (match arg
+                    ((or "manifests" "store")
+                     (alist-cons 'method (string->symbol arg)
+                                 (alist-delete 'method result)))
+                    (_
+                     (leave (G_ "~a: unknown indexing method~%"))))))))
+
+(define %default-options
+  `((database . ,suitable-database)
+    (method . manifests)))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define-command (guix-locate . args)
+  (category packaging)
+  (synopsis "search for packages providing a given file")
+
+  (define age-update-threshold
+    ;; Time since database modification after which an update is triggered.
+    (* 2 30 (* 24 60 60)))
+
+  (define age-cleanup-threshold
+    ;; Time since database modification after which it is cleared.  This is to
+    ;; avoid having stale info in the database and an endlessly growing
+    ;; database.
+    (* 9 30 (* 24 60 60)))
+
+  (define (file-age stat)
+    ;; Return true if TIME denotes an "old" time.
+    (- (current-time) (stat:mtime stat)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:build-options? #f
+                                         #:argument-handler
+                                         (lambda (arg result)
+                                           (alist-cons 'argument arg
+                                                       result))))
+           (clear?   (assoc-ref opts 'clear?))
+           (update?  (assoc-ref opts 'update?))
+           (glob?    (assoc-ref opts 'glob?))
+           (database ((assoc-ref opts 'database) update?))
+           (method   (assoc-ref opts 'method))
+           (files    (reverse (filter-map (match-lambda
+                                            (('argument . arg) arg)
+                                            (_ #f))
+                                          opts))))
+      (define* (populate-database database clear?)
+        (mkdir-p (dirname database))
+        (call-with-database database
+          (lambda (db)
+            (when clear?
+              (clear-database db))
+            (match method
+              ('manifests
+               (index-packages-from-manifests-with-db db))
+              ('store
+               (index-packages-from-store-with-db db))
+              (_
+               (leave (G_ "~a: unknown indexing method~%") method))))))
+
+      ;; Populate the database if needed.
+      (let* ((stat   (stat database #f))
+             (age    (and stat (file-age stat)))
+             (clear? (or clear?
+                         (and age (>= age age-cleanup-threshold)))))
+        (when (or update? clear?
+                  (not stat)
+                  (>= age age-update-threshold))
+          (when clear?
+            (info (G_ "clearing database...~%")))
+          (info (G_ "indexing files from ~a...~%") (%store-prefix))
+          (populate-database database clear?)))
+
+      (if (assoc-ref opts 'stats?)
+          (print-statistics database)
+          (match (call-with-database database
+                   (lambda (db)
+                     (append-map (lambda (file)
+                                   (matching-packages db file
+                                                      #:glob? glob?))
+                                 files)))
+            (()
+             (if (null? files)
+                 (unless update?
+                   (leave (G_ "no files to search for~%")))
+                 (leave (N_ "file~{ '~a'~} not found in database '~a'~%"
+                            "files~{ '~a'~} not found in database '~a'~%"
+                            (length files))
+                        files database)))
+            (matches
+             (leave-on-EPIPE
+              (print-matching-results matches))))))))