summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-11-30 15:25:21 +0100
committerLudovic Courtès <ludo@gnu.org>2023-06-18 23:44:29 +0200
commit1b7aabbc79969a89141aadd3d41d7a5329a3462e (patch)
tree4edca1e531817362e733c9210d478b8561b52113 /guix/scripts
parent1261ce15233cbf7e24de9959df86a23b46314a28 (diff)
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>
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/locate.scm659
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))))))))