[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/03: Add 'guix locate'.
|
From: |
guix-commits |
|
Subject: |
02/03: Add 'guix locate'. |
|
Date: |
Sun, 18 Jun 2023 17:47:39 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 1b7aabbc79969a89141aadd3d41d7a5329a3462e
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Nov 30 15:25:21 2022 +0100
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>
---
Makefile.am | 2 +
doc/guix.texi | 130 ++++++++++
guix/scripts/locate.scm | 659 ++++++++++++++++++++++++++++++++++++++++++++++++
po/guix/POTFILES.in | 1 +
tests/guix-locate.sh | 72 ++++++
5 files changed, 864 insertions(+)
diff --git a/Makefile.am b/Makefile.am
index ab901df757..a386e6033c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -306,6 +306,7 @@ MODULES = \
guix/scripts/archive.scm \
guix/scripts/import.scm \
guix/scripts/package.scm \
+ guix/scripts/locate.scm \
guix/scripts/install.scm \
guix/scripts/remove.scm \
guix/scripts/upgrade.scm \
@@ -595,6 +596,7 @@ SH_TESTS = \
tests/guix-gc.sh \
tests/guix-git-authenticate.sh \
tests/guix-hash.sh \
+ tests/guix-locate.sh \
tests/guix-pack.sh \
tests/guix-pack-localstatedir.sh \
tests/guix-pack-relocatable.sh \
diff --git a/doc/guix.texi b/doc/guix.texi
index eb6cc9a875..c961f706ec 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -258,6 +258,7 @@ Package Management
* Invoking guix package:: Package installation, removal, etc.
* Substitutes:: Downloading pre-built binaries.
* Packages with Multiple Outputs:: Single source package, multiple outputs.
+* Invoking guix locate:: Locating packages that provide a file.
* Invoking guix gc:: Running the garbage collector.
* Invoking guix pull:: Fetching the latest Guix and distribution.
* Invoking guix time-machine:: Running an older revision of Guix.
@@ -3297,6 +3298,7 @@ guix install emacs-guix
* Invoking guix package:: Package installation, removal, etc.
* Substitutes:: Downloading pre-built binaries.
* Packages with Multiple Outputs:: Single source package, multiple outputs.
+* Invoking guix locate:: Locating packages that provide a file.
* Invoking guix gc:: Running the garbage collector.
* Invoking guix pull:: Fetching the latest Guix and distribution.
* Invoking guix time-machine:: Running an older revision of Guix.
@@ -4417,6 +4419,134 @@ the output of @command{guix package --list-available}
(@pxref{Invoking
guix package}).
+@node Invoking guix locate
+@section Invoking @command{guix locate}
+
+@cindex file, searching in packages
+@cindex file search
+@cindex searching for packages
+There's so much free software out there that sooner or later, you will
+need to search for packages. The @command{guix search} command that
+we've seen before (@pxref{Invoking guix package}) lets you search by
+keywords:
+
+@example
+guix search video editor
+@end example
+
+@cindex searching for packages, by file name
+Sometimes, you instead want to find which package provides a given file,
+and this is where @command{guix locate} comes in. Here is how you can
+find which package provides the @command{ls} command:
+
+@example
+$ guix locate ls
+coreutils@@9.1 /gnu/store/@dots{}-coreutils-9.1/bin/ls
+@end example
+
+Of course the command works for any file, not just commands:
+
+@example
+$ guix locate unistr.h
+icu4c@@71.1 /gnu/store/@dots{}/include/unicode/unistr.h
+libunistring@@1.0 /gnu/store/@dots{}/include/unistr.h
+@end example
+
+You may also specify @dfn{glob patterns} with wildcards. For example,
+here is how you would search for packages providing @file{.service}
+files:
+
+@example
+$ guix locate -g '*.service'
+man-db@@2.11.1 @dots{}/lib/systemd/system/man-db.service
+wpa-supplicant@@2.10 @dots{}/system-services/fi.w1.wpa_supplicant1.service
+@end example
+
+The @command{guix locate} command relies on a database that maps file
+names to package names. By default, it automatically creates that
+database if it does not exist yet by traversing packages available
+@emph{locally}, which can take a few minutes (depending on the size of
+your store and the speed of your storage device).
+
+@quotation Note
+For now, @command{guix locate} builds its database based on purely local
+knowledge---meaning that you will not find packages that never reached
+your store. Eventually it will support downloading a pre-built database
+so you can potentially find more packages.
+@end quotation
+
+By default, @command{guix locate} first tries to look for a system-wide
+database, usually under @file{/var/cache/guix/locate}; if it does not
+exist or is too old, it falls back to the per-user database, by default
+under @file{~/.cache/guix/locate}. On a multi-user system,
+administrators may want to periodically update the system-wide database
+so that all users can benefit from it.
+
+The general syntax is:
+
+@example
+guix locate [@var{options}@dots{}] @var{file}@dots{}
+@end example
+
+@noindent
+... where @var{file} is the name of a file to search for (specifically,
+the ``base name'' of the file: files whose parent directories are called
+@var{file} are not matched).
+
+The available options are as follows:
+
+@table @code
+@item --glob
+@item -g
+Interpret @var{file}@dots{} as @dfn{glob patterns}---patterns that may
+include wildcards, such as @samp{*.scm} to denote all files ending in
+@samp{.scm}.
+
+@item --stats
+Display database statistics.
+
+@item --update
+@itemx -u
+Update the file database.
+
+By default, the database is automatically updated when it is too old.
+
+@item --clear
+Clear the database and re-populate it.
+
+This option lets you start anew, ensuring old data is removed from the
+database, which also avoids having an endlessly growing database. By
+default @command{guix locate} automatically does that periodically,
+though infrequently.
+
+@item --database=@var{file}
+Use @var{file} as the database, creating it if necessary.
+
+By default, @command{guix locate} picks the database under
+@file{~/.cache/guix} or @file{/var/cache/guix}, whichever is the most
+recent one.
+
+@item --method=@var{method}
+@itemx -m @var{method}
+Use @var{method} to select the set of packages to index. Possible
+values are:
+
+@table @code
+@item manifests
+This is the default method: it works by traversing profiles on the
+machine and recording packages it encounters---packages you or other
+users of the machine installed, directly or indirectly. It is fast but
+it can miss other packages available in the store but not referred to by
+any profile.
+
+@item store
+This is a slower but more exhaustive method: it checks among all the
+existing packages those that are available in the store and records
+them.
+@end table
+@end table
+
+
@node Invoking guix gc
@section Invoking @command{guix gc}
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))))))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 0431de522b..154ad4e530 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -111,6 +111,7 @@ guix/scripts/system.scm
guix/scripts/system/edit.scm
guix/scripts/system/search.scm
guix/scripts/lint.scm
+guix/scripts/locate.scm
guix/scripts/publish.scm
guix/scripts/edit.scm
guix/scripts/size.scm
diff --git a/tests/guix-locate.sh b/tests/guix-locate.sh
new file mode 100755
index 0000000000..43f8ba53b0
--- /dev/null
+++ b/tests/guix-locate.sh
@@ -0,0 +1,72 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2023 Antoine R. Dumont <antoine.romain.dumont@gmail.com>
+# Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
+#
+# 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 locate' command-line utility.
+#
+
+set -x
+
+RUN_EXPENSIVE_TESTS="${RUN_EXPENSIVE_TESTS:-false}"
+
+tmpdir="guix-index-$$"
+# In the following tests, we use two different databases, one for each
+# indexation method.
+tmpdb_manifests="$tmpdir/manifests/db.sqlite"
+tmpdb_store="$tmpdir/store/db.sqlite"
+trap 'rm -rf "$tmpdir" "$tmpdb_store" "$tmpdb_manifests"' EXIT
+
+guix locate --version
+
+# Preparing db locations for both indexation methods.
+mkdir -p "$(dirname "$tmpdb_manifests")" "$(dirname "$tmpdb_store")"
+
+cmd_manifests="guix locate --database=$tmpdb_manifests --method=manifests"
+cmd_store="guix locate --database=$tmpdb_store --method=store"
+
+# Lookup without any db should fail.
+guix locate --database="$tmpdb_manifests" guile && false
+guix locate --database="$tmpdb_store" guile && false
+
+# Lookup without anything in db should yield no results because the indexer
+# didn't stumble upon any profile.
+test -z "$(guix locate --database="$tmpdb_manifests" guile)"
+
+# Install a package.
+guix package --bootstrap --install guile-bootstrap \
+ --profile="$tmpdir/profile"
+
+# Look for 'guile'.
+$cmd_manifests --update
+$cmd_manifests guile | grep "$(guix build guile-bootstrap)/bin/guile"
+$cmd_manifests boot-9.scm | grep ^guile-bootstrap
+
+# Using a glob pattern.
+$cmd_manifests -g '*.scm' | grep "^guile-bootstrap.*boot-9"
+
+# Statistics.
+$cmd_manifests --stats
+
+if $RUN_EXPENSIVE_TESTS
+then
+ $cmd_store --update
+ $cmd_store guile
+ $cmd_store guile | grep "$(guix build guile-bootstrap)/bin/guile"
+ $cmd_store boot-9.scm | grep ^guile-bootstrap
+fi