;;; 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;
")))
;; XXX: missing in guile-sqlite3@0.1.3
(define SQLITE_BUSY 5)
(define (call-with-database file proc)
(catch 'sqlite-error
(lambda ()
(let ((db (sqlite-open file)))
(dynamic-wind
(lambda () #t)
(lambda ()
(ensure-latest-database-schema db)
(proc db))
(lambda () (sqlite-close db)))))
(lambda (key who code errmsg)
(if (= code SQLITE_BUSY)
(leave (G_ "~a: database is locked by another process~%")
file)
(throw key who code errmsg)))))
(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 (file-age stat)
"Return the age of the file denoted by STAT in seconds."
(- (current-time) (stat:mtime stat)))
(define (suitable-database create? age-update-threshold)
"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. Do not return the system database if it is older than
AGE-UPDATE-THRESHOLD seconds."
(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))
(< (file-age system) age-update-threshold))
system-database-file
user-database-file)
(if (and system
(< (file-age system) age-update-threshold))
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)
(match (false-if-exception (profile-manifest profile))
(#f
;; PROFILE's manifest is unreadable for some reason such as an
;; unsupported version.
(loop visited rest entries))
(manifest
(let ((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 (leave-on-EPIPE (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)))
(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? age-update-threshold))
(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 (or update? (assoc-ref opts 'clear?))
(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))))))))