[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#62264] [PATCH core-updates 1-6/6] Add `guix index` subcommand
|
From: |
Antoine R. Dumont |
|
Subject: |
[bug#62264] [PATCH core-updates 1-6/6] Add `guix index` subcommand |
|
Date: |
Sat, 18 Mar 2023 17:57:10 +0100 |
Hello again,
please find enclosed the remaining patches holding the actual guix
subcommand as described in the introductory email.
Cheers,
--
tony / Antoine R. Dumont (@ardumont)
-----------------------------------------------------------------
gpg fingerprint BF00 203D 741A C9D5 46A8 BE07 52E2 E984 0D10 C3B8
From 869d8b4cc7cefb6d7dbe9cd1374242bf6d7c953d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 30 Nov 2022 15:25:21 +0100
Subject: [PATCH core-updates 1/6] index: Add initial implementation from
civodul
Related to https://lists.gnu.org/archive/html/guix-devel/2022-01/msg00354.html
---
guix/extensions/index.scm | 574 ++++++++++++++++++++++++++++++++++++++
guix/scripts/home.scm | 2 +-
2 files changed, 575 insertions(+), 1 deletion(-)
create mode 100644 guix/extensions/index.scm
diff --git a/guix/extensions/index.scm b/guix/extensions/index.scm
new file mode 100644
index 0000000000..d9894b213e
--- /dev/null
+++ b/guix/extensions/index.scm
@@ -0,0 +1,574 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 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/>.
+
+(define-module (guix extensions index)
+ #:use-module ((guix i18n) #:select (G_))
+ #:use-module ((guix ui) #:select (show-version-and-exit
+ show-bug-report-information
+ with-error-handling
+ string->number*))
+ #:use-module (guix scripts)
+ #:use-module (sqlite3)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 getopt-long)
+ #:use-module (guix describe)
+ #: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)
+ #:use-module ((guix progress) #:select (progress-reporter/bar
+ call-with-progress-reporter))
+ #:use-module (guix sets)
+ #:use-module ((guix utils) #:select (cache-directory))
+ #:autoload (guix build utils) (find-files)
+ #:autoload (gnu packages) (fold-packages)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-37) ;; option
+ #:use-module (srfi srfi-71)
+ #:export (guix-index))
+
+(define debug #f)
+
+(define application-version 2)
+
+;; The following schema is the full schema at the `application-version`. It
+;; should be modified according to the development required and
+;; `application-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 `application-version` (for the existing dbs to know what to migrate).
+(define schema-full
+ "
+create table if not exists SchemaVersion (
+ version integer primary key not null,
+ date date,
+ unique (version)
+);
+
+create table if not exists Packages (
+ id integer primary key autoincrement not null,
+ name text not null,
+ version text not null,
+ 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;
+")))
+
+(define (call-with-database file proc)
+ (let ((db (sqlite-open file)))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda () (proc db))
+ (lambda () (sqlite-close db)))))
+
+(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)
+VALUES (:version, CURRENT_TIMESTAMP);"
+ #:cache? #t))
+ (sqlite-exec db "begin immediate;")
+ (sqlite-bind-arguments stmt-insert-version #:version version)
+ (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 (insert-files db package version directories)
+ "Insert files from DIRECTORIES as belonging to PACKAGE at VERSION."
+ (define stmt-select-package
+ (sqlite-prepare db "\
+SELECT id FROM Packages WHERE name = :name AND version = :version;"
+ #:cache? #t))
+
+ (define stmt-insert-package
+ (sqlite-prepare db "\
+INSERT OR IGNORE INTO Packages(name, version) -- to avoid spurious writes
+VALUES (:name, :version);"
+ #:cache? #t))
+
+ (define stmt-select-directory
+ (sqlite-prepare db "\
+SELECT id FROM Directories WHERE name = :name AND 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;")
+ (sqlite-bind-arguments stmt-insert-package
+ #:name package
+ #:version version)
+ (sqlite-fold (const #t) #t stmt-insert-package)
+
+ (sqlite-bind-arguments stmt-select-package
+ #:name package
+ #:version version)
+ (match (sqlite-fold cons '() stmt-select-package)
+ ((#(package-id))
+ (when debug
+ (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)"
+ package version package-id)
+ (pk 'package package-id package))
+ (for-each (lambda (directory)
+ (define (strip file)
+ (string-drop file (+ (string-length directory) 1)))
+
+ (sqlite-reset stmt-insert-directory)
+ (sqlite-bind-arguments stmt-insert-directory
+ #:name directory
+ #:package package-id)
+ (sqlite-fold (const #t) #t stmt-insert-directory)
+
+ (sqlite-reset stmt-select-directory)
+ (sqlite-bind-arguments stmt-select-directory
+ #:name directory
+ #:package package-id)
+ (match (sqlite-fold cons '() stmt-select-directory)
+ ((#(directory-id))
+ (when debug
+ (format #t "(name, package, dir-id): (~a, ~a, ~a)\n"
+ directory package-id directory-id))
+ (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;"))
+
+
+;;;
+;;; Indexing from local packages.
+;;;
+
+(define (insert-package db package)
+ "Insert all the files of PACKAGE into DB."
+ (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)
+ directories))
+ (return #t)))))
+
+(define (insert-packages-with-progress db packages insert-package-fn)
+ "Insert PACKAGES into DB with progress bar report."
+ (let* ((nb-packages (length packages))
+ (prefix (format #f "Registering ~a packages" nb-packages))
+ (progress (progress-reporter/bar nb-packages prefix)))
+ (call-with-progress-reporter progress
+ (lambda (report)
+ (for-each (lambda (package)
+ (insert-package-fn db package)
+ (report))
+ packages)))))
+
+
+;;;
+;;; 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-item entry)))) ;FIXME: outputs?
+
+(define (index-packages-from-manifests-with-db db-pathname)
+ "Index packages entries into DB-PATHNAME from the system manifests."
+ (call-with-database db-pathname
+ (lambda (db)
+ (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 file)
+ package-match?
+ (name package-match-name)
+ (version package-match-version)
+ (file package-match-file))
+
+(define (matching-packages db file)
+ "Return unique <package-match> corresponding to packages containing FILE."
+ (define lookup-stmt
+ (sqlite-prepare db "\
+SELECT Packages.name, Packages.version, Directories.name, Files.name
+FROM Packages
+INNER JOIN Files, Directories
+ON files.basename = :file
+ AND directories.id = files.directory
+ AND packages.id = directories.package;"))
+
+ (sqlite-bind-arguments lookup-stmt #:file file)
+ (sqlite-fold (lambda (result lst)
+ (match result
+ (#(package version directory file)
+ (cons (package-match package version
+ (string-append directory "/" file))
+ lst))))
+ '() lookup-stmt))
+
+
+
+;;;
+;;; CLI
+;;;
+
+(define (index-packages-from-store-with-db db-pathname)
+ "Index local store packages using db at location DB-PATHNAME."
+ (call-with-database db-pathname
+ (lambda (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))))
+ (index-packages-from-store db))))
+
+(define (matching-packages-with-db db-pathname file)
+ "Compute list of packages referencing FILE using db at DB-PATHNAME."
+ (call-with-database db-pathname
+ (lambda (db)
+ (matching-packages db file))))
+
+(define (read-version-from-db db-pathname)
+ (call-with-database db-pathname
+ (lambda (db) (read-version db))))
+
+(define (migrate-schema-to-version db-pathname)
+ (call-with-database db-pathname
+ (lambda (db)
+ (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* ((current-db-version (read-version db))
+ (next-db-version (+ 1 current-db-version)))
+ (when (< current-db-version application-version)
+ ;; when the current db version is older than the current
application
+ (let ((schema-migration-at-version (assoc-ref schema-to-migrate
next-db-version)))
+ (when schema-migration-at-version
+ ;; migrate the schema to the next version (if it exists)
+ (sqlite-exec db schema-migration-at-version)
+ ;; insert current version
+ (insert-version db next-db-version)
+ ;; iterate over the next migration if any
+ (migrate-schema-to-version db))))))
+ (lambda (key . arg)
+ ;; exception handler in case failure to read an inexisting db
+ ;; Fallback to boostrap the schema
+ (sqlite-exec db schema-full)
+ (insert-version db application-version))))))
+
+(define (print-matching-results matches)
+ "Print the MATCHES matching results."
+ (for-each (lambda (result)
+ (format #t "~20a ~a~%"
+ (string-append (package-match-name result)
+ "@" (package-match-version result))
+ (package-match-file result)))
+ matches))
+
+(define default-db-path
+ (string-append (cache-directory #:ensure? #f)
+ "/index/db.sqlite"))
+
+(define (show-help)
+ (display (G_ "Usage: guix index [OPTIONS...] [search FILE...]
+Without argument, indexes (package, file) relationships from the machine.
+This allows indexation with 2 methods, out of the local:
+
+- manifests: This is the fastest implementation with the caveat of indexing
+less packages. That'd be typically the use case of user local indexation.
+
+- store: This is slowest implementation. It discusses with the store
+daemon. That'd be typically the use case of building the largest db in one of
+the build farm node.
+
+With 'search FILE', search for packages installing FILE.\n
+Note: Internal cache is located at ~/.cache/guix/index/db.sqlite by default.
+See --db-path for customization.\n"))
+ (newline)
+ (display (G_ "The valid values for OPTIONS are:"))
+ (newline)
+ (display (G_ "
+ -h, --help Display this help and exit"))
+ (display (G_ "
+ -V, --version Display version information and exit"))
+ (display (G_ "
+ --db-path=DIR Change default location of the cache db"))
+ (newline)
+ (display (G_ "
+ --method=METH Change default indexation method. By default it uses the
+ local \"manifests\" (faster). It can also uses the local
+ \"store\" (slower, typically on the farm build ci)."))
+ (newline)
+ (display (G_ "The valid values for ARGS are:"))
+ (newline)
+ (display (G_ "
+ search FILE Search for packages installing the FILE (from cache db)"))
+ (newline)
+ (display (G_ "
+ <EMPTY> Without any argument, it index packages. This fills in the
+ db cache using whatever indexation method is defined."))
+ (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)
+ (catch 'sqlite-error
+ (lambda ()
+ (let ((db-path (assoc-ref result 'db-path)))
+ (simple-format
+ #t
+ "Extension local cache database:\n- path: ~a\n- version:
~a\n\n"
+ db-path (read-version-from-db db-path))))
+ (lambda (key . arg) 'no-db-yet-so-nothing-to-display))
+ (show-version-and-exit "guix index")))
+ ;; index data out of the method (store or package)
+ (option '(#\d "db-path") #f #t
+ (lambda (opt name arg result)
+ (when debug
+ (format #t "%options: --db-path: opt ~a\n" opt)
+ (format #t "%options: --db-path: name ~a\n" name)
+ (format #t "%options: --db-path: arg ~a\n" arg)
+ (format #t "%options: --db-path: result ~a\n" result))
+ (alist-cons 'db-path arg
+ (alist-delete 'db-path result))))
+
+ ;; index data out of the method (store or package)
+ (option '(#\m "method") #f #t
+ (lambda (opt name arg result)
+ (when debug
+ (format #t "%options: --method: opt ~a\n" opt)
+ (format #t "%options: --method: name ~a\n" name)
+ (format #t "%options: --method: arg ~a\n" arg)
+ (format #t "%options: --method: result ~a\n" result))
+ (match arg
+ ((or "manifests" "store")
+ (alist-cons 'with-method arg
+ (alist-delete 'with-method result)))
+ (_
+ (G_ "guix index: Wrong indexation method, either manifests
+ (fast) or store (slow)~%")))))))
+
+(define %default-options
+ `((db-path . ,default-db-path)
+ (with-method . "manifests")))
+
+(define-command (guix-index . args)
+ (category extension)
+ (synopsis "Index packages to search package for a given filename")
+
+ (define (parse-sub-command arg result)
+ ;; Parse sub-command ARG and augment RESULT accordingly.
+ (when debug
+ (format #t "parse-sub-command: arg: ~a\n" arg)
+ (format #t "parse-sub-command: result: ~a\n" result)
+ (format #t "parse-sub-command: (assoc-ref result 'action): ~a\n"
(assoc-ref result 'action))
+ (format #t "parse-sub-command: (assoc-ref result 'argument): ~a\n"
(assoc-ref result 'argument)))
+ (if (assoc-ref result 'action)
+ (alist-cons 'argument arg result)
+ (let ((action (string->symbol arg)))
+ (case action
+ ((search)
+ (alist-cons 'action action result))
+ (else (leave (G_ "~a: unknown action~%") action))))))
+
+ (define (match-pair car)
+ ;; Return a procedure that matches a pair with CAR.
+ (match-lambda
+ ((head . tail)
+ (and (eq? car head) tail))
+ (_ #f)))
+
+ (define (option-arguments opts)
+ ;; Extract the plain arguments from OPTS.
+ (let* ((args (reverse (filter-map (match-pair 'argument) opts)))
+ (count (length args))
+ (action (or (assoc-ref opts 'action) 'index)))
+
+ (when debug
+ (format #t "option-arguments: args: ~a\n" args)
+ (format #t "option-arguments: count: ~a\n" count)
+ (format #t "option-arguments: action: ~a\n" action))
+
+ (define (fail)
+ (leave (G_ "wrong number of arguments for action '~a'~%")
+ action))
+
+ (unless action
+ (format (current-error-port)
+ (G_ "guix index: missing command name~%"))
+ (format (current-error-port)
+ (G_ "Try 'guix index --help' for more information.~%"))
+ (exit 1))
+ (alist-cons 'argument (string-concatenate args)
+ (alist-delete 'argument
+ (alist-cons 'action action
+ (alist-delete 'action opts))))))
+
+ (with-error-handling
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)
+ #:argument-handler
+ parse-sub-command))
+ (args (option-arguments opts))
+ (action (assoc-ref args 'action))
+ (db-path (assoc-ref args 'db-path))
+ (with-method (assoc-ref args 'with-method)))
+ (when debug
+ (format #t "main: opts: ~a\n" opts)
+ (format #t "main: args: ~a\n" args)
+ (format #t "main: action: ~a\n" action)
+ (format #t "main: db-path: ~a\n" db-path)
+ (format #t "main: with-method: ~a\n" with-method))
+
+ (match action
+ ('search
+ (unless (file-exists? db-path)
+ (format (current-error-port)
+ (G_ "guix index: The local cache db does not exist yet.
+You need to index packages first.\nTry 'guix index --help' for more
information.~%"))
+ (exit 1))
+ (let* ((file (assoc-ref args 'argument))
+ (matches (matching-packages-with-db db-path file)))
+ (print-matching-results matches)
+ (exit (pair? matches))))
+ ('index
+ (let ((db-dirpath (dirname db-path)))
+ (unless (file-exists? db-dirpath)
+ (mkdir db-dirpath)))
+ ;; Migrate/initialize db to schema at version application-version
+ (migrate-schema-to-version db-path)
+ ;; Finally index packages
+ (if (string= with-method "manifests")
+ (index-packages-from-manifests-with-db db-path)
+ (index-packages-from-store-with-db db-path)))))))
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 8ff8182a79..9a6ddae271 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -69,7 +69,7 @@ (define-module (guix scripts home)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
- #:use-module (srfi srfi-37)
+ #:use-module ((srfi srfi-37) #:select (option))
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:export (guix-home))
--
2.36.1
From 434b27de6227f5077505c1a1688a6ae500bbe56f Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <antoine.romain.dumont@gmail.com>
Date: Tue, 20 Dec 2022 16:05:50 +0100
Subject: [PATCH core-updates 2/6] scripts-index: Transform `guix index`
extension into a Guix script
---
guix/{extensions => scripts}/index.scm | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
rename guix/{extensions => scripts}/index.scm (99%)
diff --git a/guix/extensions/index.scm b/guix/scripts/index.scm
similarity index 99%
rename from guix/extensions/index.scm
rename to guix/scripts/index.scm
index d9894b213e..8d68a63847 100644
--- a/guix/extensions/index.scm
+++ b/guix/scripts/index.scm
@@ -16,7 +16,7 @@
;;; 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 extensions index)
+(define-module (guix scripts index)
#:use-module ((guix i18n) #:select (G_))
#:use-module ((guix ui) #:select (show-version-and-exit
show-bug-report-information
@@ -484,7 +484,7 @@ (define %default-options
(with-method . "manifests")))
(define-command (guix-index . args)
- (category extension)
+ (category packaging)
(synopsis "Index packages to search package for a given filename")
(define (parse-sub-command arg result)
--
2.36.1
From 8799fcfb9f6238abe0e19ce650ee7f1e2b7e0d90 Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <antoine.romain.dumont@gmail.com>
Date: Thu, 22 Dec 2022 15:53:43 +0100
Subject: [PATCH core-updates 3/6] scripts-index: Store outputs alongside
packages
---
guix/scripts/index.scm | 207 ++++++++++++++++++++++-------------------
1 file changed, 112 insertions(+), 95 deletions(-)
diff --git a/guix/scripts/index.scm b/guix/scripts/index.scm
index 8d68a63847..d1478042ab 100644
--- a/guix/scripts/index.scm
+++ b/guix/scripts/index.scm
@@ -50,7 +50,7 @@ (define-module (guix scripts index)
(define debug #f)
-(define application-version 2)
+(define application-version 3)
;; The following schema is the full schema at the `application-version`. It
;; should be modified according to the development required and
@@ -70,6 +70,7 @@ (define schema-full
id integer primary key autoincrement not null,
name text not null,
version text not null,
+ output text,
unique (name, version) -- add uniqueness constraint
);
@@ -102,6 +103,10 @@ (define schema-to-migrate '((1 . "
(2 . "
alter table SchemaVersion
add column date date;
+")
+ (3 . "
+alter table Packages
+add column output text;
")))
(define (call-with-database file proc)
@@ -133,85 +138,90 @@ (define stmt-select-version (sqlite-prepare db "\
((#(version))
version)))
-(define (insert-files db package version directories)
- "Insert files from DIRECTORIES as belonging to PACKAGE at VERSION."
- (define stmt-select-package
- (sqlite-prepare db "\
-SELECT id FROM Packages WHERE name = :name AND version = :version;"
- #:cache? #t))
-
- (define stmt-insert-package
- (sqlite-prepare db "\
-INSERT OR IGNORE INTO Packages(name, version) -- to avoid spurious writes
-VALUES (:name, :version);"
- #:cache? #t))
-
- (define stmt-select-directory
- (sqlite-prepare db "\
+(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 REPLACE INTO Packages(name, version, output)
+VALUES (:name, :version, :output);"
+ #:cache? #t))
+
+ (define stmt-select-directory
+ (sqlite-prepare db "\
SELECT id FROM Directories WHERE name = :name AND package = :package;"
- #:cache? #t))
+ #:cache? #t))
- (define stmt-insert-directory
- (sqlite-prepare db "\
+ (define stmt-insert-directory
+ (sqlite-prepare db "\
INSERT OR IGNORE INTO Directories(name, package) -- to avoid spurious writes
VALUES (:name, :package);"
- #:cache? #t))
+ #:cache? #t))
- (define stmt-insert-file
- (sqlite-prepare db "\
+ (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;")
- (sqlite-bind-arguments stmt-insert-package
- #:name package
- #:version version)
- (sqlite-fold (const #t) #t stmt-insert-package)
-
- (sqlite-bind-arguments stmt-select-package
- #:name package
- #:version version)
- (match (sqlite-fold cons '() stmt-select-package)
- ((#(package-id))
- (when debug
- (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)"
- package version package-id)
- (pk 'package package-id package))
- (for-each (lambda (directory)
- (define (strip file)
- (string-drop file (+ (string-length directory) 1)))
-
- (sqlite-reset stmt-insert-directory)
- (sqlite-bind-arguments stmt-insert-directory
- #:name directory
- #:package package-id)
- (sqlite-fold (const #t) #t stmt-insert-directory)
-
- (sqlite-reset stmt-select-directory)
- (sqlite-bind-arguments stmt-select-directory
- #:name directory
- #:package package-id)
- (match (sqlite-fold cons '() stmt-select-directory)
- ((#(directory-id))
- (when debug
- (format #t "(name, package, dir-id): (~a, ~a, ~a)\n"
- directory package-id directory-id))
- (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;"))
+ #:cache? #t))
+
+ (sqlite-exec db "begin immediate;")
+ ;; 1 record per output
+ (for-each (lambda (output)
+ (let ((out (if (string=? "out" output) "" output)))
+ (sqlite-reset stmt-insert-package)
+ (sqlite-bind-arguments stmt-insert-package
+ #:name package
+ #:version version
+ #:output out)
+ (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))
+ (when debug
+ (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)"
+ package version package-id)
+ (pk 'package package-id package))
+ (for-each (lambda (directory)
+ (define (strip file)
+ (string-drop file (+ (string-length directory) 1)))
+
+ (sqlite-reset stmt-insert-directory)
+ (sqlite-bind-arguments stmt-insert-directory
+ #:name directory
+ #:package package-id)
+ (sqlite-fold (const #t) #t stmt-insert-directory)
+
+ (sqlite-reset stmt-select-directory)
+ (sqlite-bind-arguments stmt-select-directory
+ #:name directory
+ #:package package-id)
+ (match (sqlite-fold cons '() stmt-select-directory)
+ ((#(directory-id))
+ (when debug
+ (format #t "(name, package, dir-id): (~a, ~a, ~a)\n"
+ directory package-id directory-id))
+ (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;"))
;;;
@@ -224,8 +234,9 @@ (define (insert-package db package)
(match (derivation->output-paths drv)
(((labels . directories) ...)
(when (every file-exists? directories)
- (insert-files db (package-name package) (package-version package)
- 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-fn)
@@ -283,6 +294,7 @@ (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-pathname)
@@ -298,28 +310,29 @@ (define (index-packages-from-manifests-with-db
db-pathname)
;;;
(define-record-type <package-match>
- (package-match name version file)
+ (package-match name version output file)
package-match?
- (name package-match-name)
- (version package-match-version)
- (file package-match-file))
+ (name package-match-name)
+ (version package-match-version)
+ (output package-match-output)
+ (file package-match-file))
(define (matching-packages db file)
"Return unique <package-match> corresponding to packages containing FILE."
(define lookup-stmt
(sqlite-prepare db "\
-SELECT Packages.name, Packages.version, Directories.name, Files.name
-FROM Packages
-INNER JOIN Files, Directories
-ON files.basename = :file
- AND directories.id = files.directory
- AND packages.id = directories.package;"))
+SELECT p.name, p.version, p.output, d.name, f.name
+FROM Packages p
+INNER JOIN Files f, Directories d
+ON f.basename = :file
+ AND d.id = f.directory
+ AND p.id = d.package;"))
(sqlite-bind-arguments lookup-stmt #:file file)
(sqlite-fold (lambda (result lst)
(match result
- (#(package version directory file)
- (cons (package-match package version
+ (#(package version output directory file)
+ (cons (package-match package version output
(string-append directory "/" file))
lst))))
'() lookup-stmt))
@@ -346,14 +359,12 @@ (define (insert-package-from-store db package)
(not (package-superseded package))
(supported-package? package))))))
(insert-packages-with-progress
- db packages insert-package-from-store))))
- (index-packages-from-store db))))
+ db packages insert-package-from-store)))))))
(define (matching-packages-with-db db-pathname file)
"Compute list of packages referencing FILE using db at DB-PATHNAME."
(call-with-database db-pathname
- (lambda (db)
- (matching-packages db file))))
+ (lambda (db) (matching-packages db file))))
(define (read-version-from-db db-pathname)
(call-with-database db-pathname
@@ -387,10 +398,16 @@ (define (migrate-schema-to-version db-pathname)
(define (print-matching-results matches)
"Print the MATCHES matching results."
(for-each (lambda (result)
- (format #t "~20a ~a~%"
- (string-append (package-match-name result)
- "@" (package-match-version result))
- (package-match-file 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
+ (if (string-null? output)
+ ""
+ (string-append ":" output)))
+ file)))
matches))
(define default-db-path
--
2.36.1
From ecea57fd4b46a8da5b78db17ceb7d8225a9e68e6 Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <antoine.romain.dumont@gmail.com>
Date: Fri, 24 Feb 2023 13:54:05 +0100
Subject: [PATCH core-updates 4/6] Makefile.am: Reference new script to compile
---
Makefile.am | 2 ++
1 file changed, 2 insertions(+)
diff --git a/Makefile.am b/Makefile.am
index 23b939b674..6edd5eb900 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -302,6 +302,7 @@ MODULES = \
guix/scripts/archive.scm \
guix/scripts/import.scm \
guix/scripts/package.scm \
+ guix/scripts/index.scm \
guix/scripts/install.scm \
guix/scripts/remove.scm \
guix/scripts/upgrade.scm \
@@ -589,6 +590,7 @@ SH_TESTS = \
tests/guix-gc.sh \
tests/guix-git-authenticate.sh \
tests/guix-hash.sh \
+ tests/guix-index.sh \
tests/guix-pack.sh \
tests/guix-pack-localstatedir.sh \
tests/guix-pack-relocatable.sh \
--
2.36.1
From ae756e5add599fe0bb07547b5ff43ffa22f47da0 Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <antoine.romain.dumont@gmail.com>
Date: Fri, 24 Feb 2023 13:54:17 +0100
Subject: [PATCH core-updates 5/6] Bootstrap tests for guix index subcommand
---
guix/scripts/index.scm | 4 +++
tests/guix-index.sh | 73 ++++++++++++++++++++++++++++++++++++++++++
2 files changed, 77 insertions(+)
create mode 100755 tests/guix-index.sh
diff --git a/guix/scripts/index.scm b/guix/scripts/index.scm
index d1478042ab..adf0f31269 100644
--- a/guix/scripts/index.scm
+++ b/guix/scripts/index.scm
@@ -555,6 +555,10 @@ (define (fail)
(with-error-handling
(let* ((opts (parse-command-line args %options
(list %default-options)
+ ;; ignore $GUIX_BUILD_OPTIONS
+ ;; otherwise, subcommand is not
+ ;; detected in the tests context
+ #:build-options? #f
#:argument-handler
parse-sub-command))
(args (option-arguments opts))
diff --git a/tests/guix-index.sh b/tests/guix-index.sh
new file mode 100755
index 0000000000..2c21d45a6b
--- /dev/null
+++ b/tests/guix-index.sh
@@ -0,0 +1,73 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2013, 2014, 2015, 2019, 2020, 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 index' command-line utility.
+#
+
+set -x
+
+tmpdir="guix-index-$$"
+trap 'rm -rf "$tmpdir"' EXIT
+
+guix index --version
+
+# Basic application to install and lookup through the index subcommand
+APPLICATION=guile-bootstrap
+
+# The subcommand exposes two indexation methods so far:
+# - manifests: fast and less exhaustive
+# - store: slow, exhaustive
+
+# In the following tests, we will store in 2 different dbs for both indexation
+# methods
+tmpdb_manifests="$tmpdir/manifests/db.sqlite"
+tmpdb_store="$tmpdir/store/db.sqlite"
+
+echo "### Preparing db locations for both indexation methods"
+mkdir -p `dirname $tmpdb_manifests` `dirname $tmpdb_store`
+
+cmd_manifests="guix index --db-path=$tmpdb_manifests --method=manifests"
+cmd_store="guix index --db-path=$tmpdb_store --method=store"
+
+echo "### Lookup without any db should fail"
+! $cmd_manifests search "$APPLICATION"
+! $cmd_store search "$APPLICATION"
+
+echo "### Initializing db with bare guix store should work"
+$cmd_manifests
+# ! $cmd_store
+
+echo "### lookup without anything in db should yield no result"
+! test `$cmd_manifests search "$APPLICATION"`
+# ! test `$cmd_store search "$APPLICATION"`
+
+echo "### Add some package to the temporary store"
+guix package --bootstrap \
+ --install $APPLICATION \
+ --profile=$tmpdir/profile
+
+echo "### Both both indexation call should work"
+# Testing indexation should work for both method
+test `$cmd_manifests`
+# test `$cmd_store`
+
+echo "### lookup indexed '$APPLICATION' should yield result"
+
+test `$cmd_manifests search "$APPLICATION"`
+# test `$cmd_store search "$APPLICATION"`
--
2.36.1
From 372b2b9660b8293eebd6280bb46a4ec07d4192a7 Mon Sep 17 00:00:00 2001
From: "Antoine R. Dumont (@ardumont)" <antoine.romain.dumont@gmail.com>
Date: Mon, 13 Mar 2023 13:52:38 +0100
Subject: [PATCH core-updates 6/6] Allow gcroot function to exceptionally
ignore error
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Co-authored with Ludovic Courtès <ludo@gnu.org>
---
guix/store/roots.scm | 10 +++++++++-
tests/store-roots.scm | 7 ++++++-
2 files changed, 15 insertions(+), 2 deletions(-)
diff --git a/guix/store/roots.scm b/guix/store/roots.scm
index 222f69c5c0..c2b15c33f0 100644
--- a/guix/store/roots.scm
+++ b/guix/store/roots.scm
@@ -105,7 +105,15 @@ (define canonical-root
(map (match-lambda
((file . properties)
(cons (scope file) properties)))
- (scandir* directory regular?)))))
+ (catch 'system-error
+ (lambda ()
+ (scandir* directory regular?))
+ (lambda args
+ (if (= ENOENT
+ (system-error-errno
+ args))
+ '()
+ (apply throw args))))))))
(loop (append rest (map first sub-directories))
(append (map canonical-root (filter symlink? files))
roots)
diff --git a/tests/store-roots.scm b/tests/store-roots.scm
index 5bcf1bc87e..00a4fe7931 100644
--- a/tests/store-roots.scm
+++ b/tests/store-roots.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2023 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +21,7 @@ (define-module (test-store-deduplication)
#:use-module (guix store)
#:use-module (guix store roots)
#:use-module ((guix utils) #:select (call-with-temporary-directory))
+ #:use-module ((guix config) #:select (%state-directory))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64))
@@ -29,6 +30,10 @@ (define %store
(test-begin "store-roots")
+(test-equal "gc-roots, initial"
+ (list (string-append %state-directory "/profiles"))
+ (gc-roots))
+
(test-assert "gc-roots, regular root"
(let* ((item (add-text-to-store %store "something"
(random-text)))
--
2.36.1
signature.asc
Description: PGP signature