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>master
Ludovic Courtès
parent
1261ce1523
commit
1b7aabbc79
|
|
@ -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 \
|
||||
|
|
|
|||
130
doc/guix.texi
130
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}
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Reference in New Issue