From 4c97a368a698ccf89113a258e8cf5e7947fbcc08 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jun 2018 09:28:28 +0200 Subject: substitute: Erase the current line when reporting progress. * guix/scripts/substitute.scm (fetch-narinfos)[update-progress!]: Use the ANSI erase-current-line sequence next to \r. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8e1119fb49..ab52245e8e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -613,7 +613,7 @@ if file doesn't exist, and the narinfo otherwise." (let ((done 0) (total (length paths))) (lambda () - (display #\cr (current-error-port)) + (display "\r\x1b[K" (current-error-port)) ;erase current line (force-output (current-error-port)) (format (current-error-port) (G_ "updating list of substitutes from '~a'... ~5,1f%") -- cgit v1.2.3 From 2bf9351e311cce0004756890b93f50693f133bb6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jun 2018 10:30:30 +0200 Subject: substitute: Make progress message shorter. * guix/scripts/substitute.scm (fetch-narinfos)[update-progress!]: Shorten progress message so it fits on 80 columns. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ab52245e8e..d0beacc8ea 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -616,7 +616,7 @@ if file doesn't exist, and the narinfo otherwise." (display "\r\x1b[K" (current-error-port)) ;erase current line (force-output (current-error-port)) (format (current-error-port) - (G_ "updating list of substitutes from '~a'... ~5,1f%") + (G_ "updating substitutes from '~a'... ~5,1f%") url (* 100. (/ done total))) (set! done (+ 1 done))))) -- cgit v1.2.3 From 38212ff7b91a276228d9e6b9b6e265eb1a5e6fff Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Mon, 11 Jun 2018 17:36:06 +0300 Subject: import: utils: Import more dependencies. * guix/import/utils.scm (recursive-import): Import more dependencies. --- guix/import/utils.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index df85904c6f..0dc8fd5857 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -420,7 +420,7 @@ dependencies." ;; generator: update the queue (lambda (state) (receive (package . dependencies) - (repo->guix-package package-name repo) + (repo->guix-package (next state) repo) (if package (update state (filter (cut unknown? <> (cons (next state) -- cgit v1.2.3 From e2f8be0664609223369f01290b69b44196783ab3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Jun 2018 23:39:24 +0200 Subject: pull: Add '--list-generations'. * guix/scripts/pull.scm (show-help, %options): Add '--list-generations'. (display-profile-content, process-query): New procedures. (guix-pull): Honor '--list-generations'. --- doc/guix.texi | 44 +++++++++++---- guix/scripts/pull.scm | 149 +++++++++++++++++++++++++++++++++++++------------- 2 files changed, 144 insertions(+), 49 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e734147681..4871bbcfe4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2756,25 +2756,40 @@ export PATH="$HOME/.config/guix/current/bin:$PATH" export INFOPATH="$HOME/.config/guix/current/share/info:$INFOPATH" @end example +The @code{--list-generations} or @code{-l} option lists past generations +produced by @command{guix pull}, along with details about their provenance: + +@example +$ guix pull -l +Generation 1 Jun 10 2018 00:18:18 + guix 65956ad + repository URL: https://git.savannah.gnu.org/git/guix.git + branch: origin/master + commit: 65956ad3526ba09e1f7a40722c96c6ef7c0936fe + +Generation 2 Jun 11 2018 11:02:49 + guix e0cc7f6 + repository URL: https://git.savannah.gnu.org/git/guix.git + branch: origin/master + commit: e0cc7f669bec22c37481dd03a7941c7d11a64f1d + +Generation 3 Jun 13 2018 23:31:07 (current) + guix 844cc1c + repository URL: https://git.savannah.gnu.org/git/guix.git + branch: origin/master + commit: 844cc1c8f394f03b404c5bb3aee086922373490c +@end example + This @code{~/.config/guix/current} profile works like any other profile created by @command{guix package} (@pxref{Invoking guix package}). That is, you can list generations, roll back to the previous generation---i.e., the previous Guix---and so on: @example -$ guix package -p ~/.config/guix/current -l -Generation 1 May 25 2018 10:06:41 - guix 221951a out /gnu/store/i4dfk7vw5k112s49jrhl6hwsfnh6wr7l-guix-221951af4 - -Generation 2 May 27 2018 19:07:47 - + guix 2fbae00 out /gnu/store/44cv9hyvxg34xf5kblf5dz57hc52y4bm-guix-2fbae006f - - guix 221951a out /gnu/store/i4dfk7vw5k112s49jrhl6hwsfnh6wr7l-guix-221951af4 - -Generation 3 May 30 2018 16:11:39 (current) - + guix a076f19 out /gnu/store/332czkicwwg6lc3x4aqbw5q2mq12s7fj-guix-a076f1990 - - guix 2fbae00 out /gnu/store/44cv9hyvxg34xf5kblf5dz57hc52y4bm-guix-2fbae006f $ guix package -p ~/.config/guix/current --roll-back switched from generation 3 to 2 +$ guix package -p ~/.config/guix/current --delete-generations=1 +deleting /home/charlie/.config/guix/current-1-link @end example The @command{guix pull} command is usually invoked with no arguments, @@ -2800,6 +2815,13 @@ string. Deploy the tip of @var{branch}, the name of a Git branch available on the repository at @var{url}. +@item --list-generations[=@var{pattern}] +@itemx -l [@var{pattern}] +List all the generations of @file{~/.config/guix/current} or, if @var{pattern} +is provided, the subset of generations that match @var{pattern}. +The syntax of @var{pattern} is the same as with @code{guix package +--list-generations} (@pxref{Invoking guix package}). + @item --bootstrap Use the bootstrap Guile to build the latest Guix. This option is only useful to Guix developers. diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 499de0ec45..7202e3cc16 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -45,6 +45,7 @@ #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-pull)) @@ -109,6 +110,9 @@ Download and deploy the latest version of Guix.\n")) --commit=COMMIT download the specified COMMIT")) (display (G_ " --branch=BRANCH download the tip of the specified BRANCH")) + (display (G_ " + -l, --list-generations[=PATTERN] + list generations matching PATTERN")) (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) @@ -125,6 +129,10 @@ Download and deploy the latest version of Guix.\n")) (cons* (option '("verbose") #f #f (lambda (opt name arg result) (alist-cons 'verbose? #t result))) + (option '(#\l "list-generations") #f #t + (lambda (opt name arg result) + (cons `(query list-generations ,(or arg "")) + result))) (option '("url") #t #f (lambda (opt name arg result) (alist-cons 'repository-url arg @@ -273,6 +281,66 @@ certificates~%")) (lambda (key err) (report-git-error err)))) + +;;; +;;; Queries. +;;; + +(define (display-profile-content profile number) + "Display the packages in PROFILE, generation NUMBER, in a human-readable +way and displaying details about the channel's source code." + (for-each (lambda (entry) + (format #t " ~a ~a~%" + (manifest-entry-name entry) + (manifest-entry-version entry)) + (match (assq 'source (manifest-entry-properties entry)) + (('source ('repository ('version 0) + ('url url) + ('branch branch) + ('commit commit) + _ ...)) + (format #t (G_ " repository URL: ~a~%") url) + (when branch + (format #t (G_ " branch: ~a~%") branch)) + (format #t (G_ " commit: ~a~%") commit)) + (_ #f))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries + (profile-manifest (generation-file-name profile number)))))) + +(define (process-query opts) + "Process any query specified by OPTS." + (define profile + (string-append (config-directory) "/current")) + + (match (assoc-ref opts 'query) + (('list-generations pattern) + (define (list-generation display-function number) + (unless (zero? number) + (display-generation profile number) + (display-function profile number) + (newline))) + + (leave-on-EPIPE + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (for-each (lambda (generation) + (list-generation display-profile-content generation)) + (profile-generations profile))) + ((matching-generations pattern profile) + => + (match-lambda + (() + (exit 1)) + ((numbers ...) + (for-each (lambda (generation) + (list-generation display-profile-content generation)) + numbers))))))))) + (define (guix-pull . args) (define (use-le-certs? url) @@ -287,43 +355,48 @@ certificates~%")) (cache (string-append (cache-directory) "/pull"))) (ensure-guile-git!) - (unless (assoc-ref opts 'dry-run?) ;XXX: not very useful - (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line store opts) - - ;; For reproducibility, always refer to the LE certificates when we - ;; know we're talking to Savannah. - (when (use-le-certs? url) - (honor-lets-encrypt-certificates! store)) - - (format (current-error-port) - (G_ "Updating from Git repository at '~a'...~%") - url) - - (let-values (((checkout commit) - (latest-repository-commit store url - #:ref ref - #:cache-directory cache))) - - (format (current-error-port) - (G_ "Building from Git commit ~a...~%") - commit) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install checkout (config-directory) - #:url url - #:branch (match ref - (('branch . branch) - branch) - (_ #f)) - #:commit commit - #:verbose? - (assoc-ref opts 'verbose?)))))))))))) + (cond ((assoc-ref opts 'query) + (process-query opts)) + ((assoc-ref opts 'dry-run?) + #t) ;XXX: not very useful + (else + (with-store store + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (set-build-options-from-command-line store opts) + + ;; For reproducibility, always refer to the LE certificates + ;; when we know we're talking to Savannah. + (when (use-le-certs? url) + (honor-lets-encrypt-certificates! store)) + + (format (current-error-port) + (G_ "Updating from Git repository at '~a'...~%") + url) + + (let-values (((checkout commit) + (latest-repository-commit store url + #:ref ref + #:cache-directory + cache))) + + (format (current-error-port) + (G_ "Building from Git commit ~a...~%") + commit) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + (build-and-install checkout (config-directory) + #:url url + #:branch (match ref + (('branch . branch) + branch) + (_ #f)) + #:commit commit + #:verbose? + (assoc-ref opts 'verbose?))))))))))))) ;;; pull.scm ends here -- cgit v1.2.3 From 3931c76154d4f418d5ea9acc5e47bf911d371c24 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 15:40:09 +0200 Subject: database: 'with-database' can now initialize new databases. * nix/libstore/schema.sql: Rename to... * guix/store/schema.sql: ... this. * Makefile.am (nobase_dist_guilemodule_DATA): Add it. * nix/local.mk (%D%/libstore/schema.sql.hh): Adjust accordingly. * guix/store/database.scm (sql-schema): New variable. (sqlite-exec, initialize-database, call-with-database): New procedures. (with-database): Rewrite in terms of 'call-with-database'. * tests/store-database.scm ("new database"): New test. * guix/self.scm (compiled-guix)[*core-modules*]: Add 'schema.sql' to #:extra-files. --- Makefile.am | 1 + guix/self.scm | 4 +++- guix/store/database.scm | 50 +++++++++++++++++++++++++++++++++++++++++++----- guix/store/schema.sql | 44 ++++++++++++++++++++++++++++++++++++++++++ nix/libstore/schema.sql | 44 ------------------------------------------ nix/local.mk | 2 +- tests/store-database.scm | 23 ++++++++++++++++++++++ 7 files changed, 117 insertions(+), 51 deletions(-) create mode 100644 guix/store/schema.sql delete mode 100644 nix/libstore/schema.sql (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 7898a3648a..0267e8fe50 100644 --- a/Makefile.am +++ b/Makefile.am @@ -300,6 +300,7 @@ EXAMPLES = \ GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go $(dist_noinst_DATA:%.scm=%.go) nobase_dist_guilemodule_DATA = \ + guix/store/schema.sql \ $(MODULES) $(MODULES_NOT_COMPILED) $(AUX_FILES) $(EXAMPLES) \ $(MISC_DISTRO_FILES) nobase_nodist_guilemodule_DATA = guix/config.scm diff --git a/guix/self.scm b/guix/self.scm index e71e086cdc..ed3f31cdbc 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -482,7 +482,9 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the ;; but we don't need to compile it; not compiling it allows ;; us to avoid an extra dependency on guile-gdbm-ffi. #:extra-files - `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm"))) + `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm")) + ("guix/store/schema.sql" + ,(local-file "../guix/store/schema.sql"))) #:guile-for-build guile-for-build)) diff --git a/guix/store/database.scm b/guix/store/database.scm index 3623c0e7a0..e81ab3dc99 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -24,25 +24,65 @@ #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix build syscalls) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #:use-module (rnrs io ports) #:use-module (ice-9 match) - #:export (sqlite-register + #:use-module (system foreign) + #:export (sql-schema + with-database + sqlite-register register-path reset-timestamps)) ;;; Code for working with the store database directly. +(define sql-schema + ;; Name of the file containing the SQL scheme or #f. + (make-parameter #f)) -(define-syntax-rule (with-database file db exp ...) - "Open DB from FILE and close it when the dynamic extent of EXP... is left." - (let ((db (sqlite-open file))) +(define sqlite-exec + ;; XXX: This is was missing from guile-sqlite3 until + ;; . + (let ((exec (pointer->procedure + int + (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) + '(* * * * *)))) + (lambda (db text) + (let ((ret (exec ((@@ (sqlite3) db-pointer) db) + (string->pointer text) + %null-pointer %null-pointer %null-pointer))) + (unless (zero? ret) + ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret)))))) + +(define (initialize-database db) + "Initializing DB, an empty database, by creating all the tables and indexes +as specified by SQL-SCHEMA." + (define schema + (or (sql-schema) + (search-path %load-path "guix/store/schema.sql"))) + + (sqlite-exec db (call-with-input-file schema get-string-all))) + +(define (call-with-database file proc) + "Pass PROC a database record corresponding to FILE. If FILE doesn't exist, +create it and initialize it as a new database." + (let ((new? (not (file-exists? file))) + (db (sqlite-open file))) (dynamic-wind noop (lambda () - exp ...) + (when new? + (initialize-database db)) + (proc db)) (lambda () (sqlite-close db))))) +(define-syntax-rule (with-database file db exp ...) + "Open DB from FILE and close it when the dynamic extent of EXP... is left. +If FILE doesn't exist, create it and initialize it as a new database." + (call-with-database file (lambda (db) exp ...))) + (define (last-insert-row-id db) ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. ;; Work around that. diff --git a/guix/store/schema.sql b/guix/store/schema.sql new file mode 100644 index 0000000000..c1b4a689af --- /dev/null +++ b/guix/store/schema.sql @@ -0,0 +1,44 @@ +create table if not exists ValidPaths ( + id integer primary key autoincrement not null, + path text unique not null, + hash text not null, + registrationTime integer not null, + deriver text, + narSize integer +); + +create table if not exists Refs ( + referrer integer not null, + reference integer not null, + primary key (referrer, reference), + foreign key (referrer) references ValidPaths(id) on delete cascade, + foreign key (reference) references ValidPaths(id) on delete restrict +); + +create index if not exists IndexReferrer on Refs(referrer); +create index if not exists IndexReference on Refs(reference); + +-- Paths can refer to themselves, causing a tuple (N, N) in the Refs +-- table. This causes a deletion of the corresponding row in +-- ValidPaths to cause a foreign key constraint violation (due to `on +-- delete restrict' on the `reference' column). Therefore, explicitly +-- get rid of self-references. +create trigger if not exists DeleteSelfRefs before delete on ValidPaths + begin + delete from Refs where referrer = old.id and reference = old.id; + end; + +create table if not exists DerivationOutputs ( + drv integer not null, + id text not null, -- symbolic output id, usually "out" + path text not null, + primary key (drv, id), + foreign key (drv) references ValidPaths(id) on delete cascade +); + +create index if not exists IndexDerivationOutputs on DerivationOutputs(path); + +create table if not exists FailedPaths ( + path text primary key not null, + time integer not null +); diff --git a/nix/libstore/schema.sql b/nix/libstore/schema.sql deleted file mode 100644 index c1b4a689af..0000000000 --- a/nix/libstore/schema.sql +++ /dev/null @@ -1,44 +0,0 @@ -create table if not exists ValidPaths ( - id integer primary key autoincrement not null, - path text unique not null, - hash text not null, - registrationTime integer not null, - deriver text, - narSize integer -); - -create table if not exists Refs ( - referrer integer not null, - reference integer not null, - primary key (referrer, reference), - foreign key (referrer) references ValidPaths(id) on delete cascade, - foreign key (reference) references ValidPaths(id) on delete restrict -); - -create index if not exists IndexReferrer on Refs(referrer); -create index if not exists IndexReference on Refs(reference); - --- Paths can refer to themselves, causing a tuple (N, N) in the Refs --- table. This causes a deletion of the corresponding row in --- ValidPaths to cause a foreign key constraint violation (due to `on --- delete restrict' on the `reference' column). Therefore, explicitly --- get rid of self-references. -create trigger if not exists DeleteSelfRefs before delete on ValidPaths - begin - delete from Refs where referrer = old.id and reference = old.id; - end; - -create table if not exists DerivationOutputs ( - drv integer not null, - id text not null, -- symbolic output id, usually "out" - path text not null, - primary key (drv, id), - foreign key (drv) references ValidPaths(id) on delete cascade -); - -create index if not exists IndexDerivationOutputs on DerivationOutputs(path); - -create table if not exists FailedPaths ( - path text primary key not null, - time integer not null -); diff --git a/nix/local.mk b/nix/local.mk index 39717711f8..b4c6ba61a4 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -163,7 +163,7 @@ noinst_HEADERS = \ $(libformat_headers) $(libutil_headers) $(libstore_headers) \ $(guix_daemon_headers) -%D%/libstore/schema.sql.hh: %D%/libstore/schema.sql +%D%/libstore/schema.sql.hh: guix/store/schema.sql $(AM_V_GEN)$(GUILE) --no-auto-compile -c \ "(use-modules (rnrs io ports)) \ (call-with-output-file \"$@\" \ diff --git a/tests/store-database.scm b/tests/store-database.scm index 1348a75c26..7947368595 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module ((guix store) #:hide (register-path)) #:use-module (guix store database) + #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64)) @@ -51,4 +52,26 @@ (null? (valid-derivers %store file)) (null? (referrers %store file)))))) +(test-equal "new database" + (list 1 2) + (call-with-temporary-output-file + (lambda (db-file port) + (delete-file db-file) + (sqlite-register #:db-file db-file + #:path "/gnu/foo" + #:references '() + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size 1234) + (sqlite-register #:db-file db-file + #:path "/gnu/bar" + #:references '("/gnu/foo") + #:deriver "/gnu/bar.drv" + #:hash (string-append "sha256:" (make-string 64 #\a)) + #:nar-size 4321) + (let ((path-id (@@ (guix store database) path-id))) + (with-database db-file db + (list (path-id db "/gnu/foo") + (path-id db "/gnu/bar"))))))) + (test-end "store-database") -- cgit v1.2.3 From f8f9f7cabca3f0ea1f8b8cb4fecfc45889bdfb94 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 18:33:19 +0200 Subject: database: Fail registration when encountering unregistered references. * guix/store/database.scm (add-reference-sql): Remove nested SELECT. (add-references): Expect REFERENCES to be a list of ids. (sqlite-register): Call 'path-id' for each of REFERENCES and pass it to 'add-references'. * tests/store-database.scm ("register-path with unregistered references"): New test. --- guix/store/database.scm | 18 +++++++++++------- tests/store-database.scm | 20 ++++++++++++++++++++ 2 files changed, 31 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index e81ab3dc99..d5e34ef044 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (system foreign) @@ -139,13 +140,11 @@ of course. Returns the row id of the row that was modified or inserted." (last-insert-row-id db))))) (define add-reference-sql - "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id -FROM ValidPaths WHERE path = :reference") + "INSERT INTO Refs (referrer, reference) VALUES (:referrer, :reference);") (define (add-references db referrer references) "REFERRER is the id of the referring store item, REFERENCES is a list -containing store items being referred to. Note that all of the store items in -REFERENCES must already be registered." +ids of items referred to." (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) (for-each (lambda (reference) (sqlite-reset stmt) @@ -164,15 +163,20 @@ path of some store item, REFERENCES is a list of string paths which the store item PATH refers to (they need to be already registered!), DERIVER is a string path of the derivation that created the store item PATH, HASH is the base16-encoded sha256 hash of the store item denoted by PATH (prefixed with -\"sha256:\") after being converted to nar form, and nar-size is the size in -bytes of the store item denoted by PATH after being converted to nar form." +\"sha256:\") after being converted to nar form, and NAR-SIZE is the size in +bytes of the store item denoted by PATH after being converted to nar form. + +Every store item in REFERENCES must already be registered." (with-database db-file db (let ((id (update-or-insert db #:path path #:deriver deriver #:hash hash #:nar-size nar-size #:time (time-second (current-time time-utc))))) - (add-references db id references)))) + ;; Call 'path-id' on each of REFERENCES. This ensures we get a + ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. + (add-references db id + (map (cut path-id db <>) references))))) ;;; diff --git a/tests/store-database.scm b/tests/store-database.scm index 7947368595..9562055fd1 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -74,4 +74,24 @@ (list (path-id db "/gnu/foo") (path-id db "/gnu/bar"))))))) +(test-assert "register-path with unregistered references" + ;; Make sure we get a "NOT NULL constraint failed: Refs.reference" error + ;; when we try to add references that are not registered yet. Better safe + ;; than sorry. + (call-with-temporary-output-file + (lambda (db-file port) + (delete-file db-file) + (catch 'sqlite-error + (lambda () + (sqlite-register #:db-file db-file + #:path "/gnu/foo" + #:references '("/gnu/bar") + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size 1234) + #f) + (lambda args + (pk 'welcome-exception! args) + #t))))) + (test-end "store-database") -- cgit v1.2.3 From 6892f0a247a06ac12c8c462692f8b3f93e872911 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 22:06:34 +0200 Subject: store-copy: 'read-reference-graph' returns a list of records. The previous implementation of 'read-reference-graph' was good enough for many use cases, but it discarded the graph structure, which is useful information in some cases. * guix/build/store-copy.scm (): New record type. (read-reference-graph): Rewrite to return a list of . (closure-size, populate-store): Adjust accordingly. * gnu/services/base.scm (references-file): Adjust accordingly. * gnu/system/vm.scm (system-docker-image): Likewise. * guix/scripts/pack.scm (squashfs-image, docker-image): Likewise. * tests/gexp.scm ("gexp->derivation #:references-graphs"): Likewise. --- gnu/services/base.scm | 5 +- gnu/system/vm.scm | 6 ++- guix/build/store-copy.scm | 120 +++++++++++++++++++++++++++++++++++++++------- guix/scripts/pack.scm | 10 ++-- tests/gexp.scm | 17 ++++--- 5 files changed, 128 insertions(+), 30 deletions(-) (limited to 'guix') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index b34bb7132b..68411439db 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1592,8 +1592,9 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (call-with-output-file #$output (lambda (port) - (write (call-with-input-file "graph" - read-reference-graph) + (write (map store-info-item + (call-with-input-file "graph" + read-reference-graph)) port))))) #:options `(#:local-build? #f #:references-graphs (("graph" ,item)))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 544c0e294d..4aea53d1cd 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -466,8 +466,10 @@ should set REGISTER-CLOSURES? to #f." (build-docker-image (string-append "/xchg/" #$name) ;; The output file. (cons* root-directory - (call-with-input-file (string-append "/xchg/" #$graph) - read-reference-graph)) + (map store-info-item + (call-with-input-file + (string-append "/xchg/" #$graph) + read-reference-graph))) #$os-drv #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:creation-time (make-time time-utc 0 1) diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index fe2eb6f69a..bad1c09cba 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,10 +18,21 @@ (define-module (guix build store-copy) #:use-module (guix build utils) + #:use-module (guix sets) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 ftw) - #:export (read-reference-graph + #:use-module (ice-9 vlist) + #:export (store-info? + store-info-item + store-info-deriver + store-info-references + + read-reference-graph + closure-size populate-store)) @@ -34,19 +45,94 @@ ;;; ;;; Code: +;; Information about a store item as produced by #:references-graphs. +(define-record-type + (store-info item deriver references) + store-info? + (item store-info-item) ;string + (deriver store-info-deriver) ;#f | string + (references store-info-references)) ;? + +;; TODO: Factorize with that in (guix store). +(define (topological-sort nodes edges) + "Return NODES in topological order according to EDGES. EDGES must be a +one-argument procedure that takes a node and returns the nodes it is connected +to." + (define (traverse) + ;; Do a simple depth-first traversal of all of PATHS. + (let loop ((nodes nodes) + (visited (setq)) + (result '())) + (match nodes + ((head tail ...) + (if (set-contains? visited head) + (loop tail visited result) + (call-with-values + (lambda () + (loop (edges head) + (set-insert head visited) + result)) + (lambda (visited result) + (loop tail visited (cons head result)))))) + (() + (values visited result))))) + + (call-with-values traverse + (lambda (_ result) + (reverse result)))) + (define (read-reference-graph port) - "Return a list of store paths from the reference graph at PORT. -The data at PORT is the format produced by #:references-graphs." - (let loop ((line (read-line port)) - (result '())) - (cond ((eof-object? line) - (delete-duplicates result)) - ((string-prefix? "/" line) - (loop (read-line port) - (cons line result))) - (else - (loop (read-line port) - result))))) + "Read the reference graph as produced by #:references-graphs from PORT and +return it as a list of records in topological order--i.e., leaves +come first. IOW, store items in the resulting list can be registered in the +order in which they appear. + +The reference graph format consists of sequences of lines like this: + + FILE + DERIVER + NUMBER-OF-REFERENCES + REF1 + ... + REFN + +It is meant as an internal format." + (let loop ((result '()) + (table vlist-null) + (referrers vlist-null)) + (match (read-line port) + ((? eof-object?) + ;; 'guix-daemon' gives us something that's in "reverse topological + ;; order"--i.e., leaves (items with zero references) come last. Here + ;; we compute the topological order that we want: leaves come first. + (let ((unreferenced? (lambda (item) + (let ((referrers (vhash-fold* cons '() + (store-info-item item) + referrers))) + (or (null? referrers) + (equal? (list item) referrers)))))) + (topological-sort (filter unreferenced? result) + (lambda (item) + (map (lambda (item) + (match (vhash-assoc item table) + ((_ . node) node))) + (store-info-references item)))))) + (item + (let* ((deriver (match (read-line port) + ("" #f) + (line line))) + (count (string->number (read-line port))) + (refs (unfold-right (cut >= <> count) + (lambda (n) + (read-line port)) + 1+ + 0)) + (item (store-info item deriver refs))) + (loop (cons item result) + (vhash-cons (store-info-item item) item table) + (fold (cut vhash-cons <> item <>) + referrers + refs))))))) (define (file-size file) "Return the size of bytes of FILE, entering it if FILE is a directory." @@ -72,7 +158,8 @@ The data at PORT is the format produced by #:references-graphs." "Return an estimate of the size of the closure described by REFERENCE-GRAPHS, a list of reference-graph files." (define (graph-from-file file) - (call-with-input-file file read-reference-graph)) + (map store-info-item + (call-with-input-file file read-reference-graph))) (define items (delete-duplicates (append-map graph-from-file reference-graphs))) @@ -88,7 +175,8 @@ REFERENCE-GRAPHS, a list of reference-graph files." (define (things-to-copy) ;; Return the list of store files to copy to the image. (define (graph-from-file file) - (call-with-input-file file read-reference-graph)) + (map store-info-item + (call-with-input-file file read-reference-graph))) (delete-duplicates (append-map graph-from-file reference-graphs))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 76729d8e10..78bfd01eff 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -251,8 +251,9 @@ added to the pack." ;; ancestor directories and only keeps the basename. We fix this ;; in the following invocations of mksquashfs. (apply invoke "mksquashfs" - `(,@(call-with-input-file "profile" - read-reference-graph) + `(,@(map store-info-item + (call-with-input-file "profile" + read-reference-graph)) ,#$output ;; Do not perform duplicate checking because we @@ -352,8 +353,9 @@ the image." (setenv "PATH" (string-append #$archiver "/bin")) (build-docker-image #$output - (call-with-input-file "profile" - read-reference-graph) + (map store-info-item + (call-with-input-file "profile" + read-reference-graph)) #$profile #:system (or #$target (utsname:machine (uname))) #:symlinks '#$symlinks diff --git a/tests/gexp.scm b/tests/gexp.scm index a560adfc5c..83fe811546 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -615,6 +615,7 @@ `(("graph" ,two)) #:modules '((guix build store-copy) + (guix sets) (guix build utils)))) (ok? (built-derivations (list drv))) (out -> (derivation->output-path drv))) @@ -815,21 +816,25 @@ (two (gexp->derivation "two" #~(symlink #$one #$output:chbouib))) (build -> (with-imported-modules '((guix build store-copy) + (guix sets) (guix build utils)) #~(begin (use-modules (guix build store-copy)) (with-output-to-file #$output (lambda () - (write (call-with-input-file "guile" - read-reference-graph)))) + (write (map store-info-item + (call-with-input-file "guile" + read-reference-graph))))) (with-output-to-file #$output:one (lambda () - (write (call-with-input-file "one" - read-reference-graph)))) + (write (map store-info-item + (call-with-input-file "one" + read-reference-graph))))) (with-output-to-file #$output:two (lambda () - (write (call-with-input-file "two" - read-reference-graph))))))) + (write (map store-info-item + (call-with-input-file "two" + read-reference-graph)))))))) (drv (gexp->derivation "ref-graphs" build #:references-graphs `(("one" ,one) ("two" ,two "chbouib") -- cgit v1.2.3 From 33fddb763a71970961e87d26f222951ab7cd353c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 22:35:48 +0200 Subject: database: Provide a way to specify the schema location. * guix/store/database.scm (sqlite-register): Add #:schema. Parameterize 'sql-schema' based on this. (register-path): Add #:schema and pass it to 'sqlite-register'. --- guix/store/database.scm | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index d5e34ef044..0f6d2e2c06 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -88,7 +88,7 @@ If FILE doesn't exist, create it and initialize it as a new database." ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. ;; Work around that. (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" - #:cache? #t)) + #:cache? #t)) (result (sqlite-fold cons '() stmt))) (sqlite-finalize stmt) (match result @@ -157,7 +157,8 @@ ids of items referred to." ;; XXX figure out caching of statement and database objects... later (define* (sqlite-register #:key db-file path (references '()) - deriver hash nar-size) + deriver hash nar-size + (schema (sql-schema))) "Registers this stuff in a database specified by DB-FILE. PATH is the string path of some store item, REFERENCES is a list of string paths which the store item PATH refers to (they need to be already registered!), DERIVER is a string @@ -167,16 +168,17 @@ base16-encoded sha256 hash of the store item denoted by PATH (prefixed with bytes of the store item denoted by PATH after being converted to nar form. Every store item in REFERENCES must already be registered." - (with-database db-file db - (let ((id (update-or-insert db #:path path - #:deriver deriver - #:hash hash - #:nar-size nar-size - #:time (time-second (current-time time-utc))))) - ;; Call 'path-id' on each of REFERENCES. This ensures we get a - ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. - (add-references db id - (map (cut path-id db <>) references))))) + (parameterize ((sql-schema schema)) + (with-database db-file db + (let ((id (update-or-insert db #:path path + #:deriver deriver + #:hash hash + #:nar-size nar-size + #:time (time-second (current-time time-utc))))) + ;; Call 'path-id' on each of REFERENCES. This ensures we get a + ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. + (add-references db id + (map (cut path-id db <>) references)))))) ;;; @@ -221,7 +223,8 @@ it's a directory." (define* (register-path path #:key (references '()) deriver prefix - state-directory (deduplicate? #t)) + state-directory (deduplicate? #t) + (schema (sql-schema))) ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and ;; %store-database-directory already handle the "environment variables / @@ -267,6 +270,7 @@ be used internally by the daemon's build hook." (reset-timestamps real-path) (sqlite-register #:db-file (string-append db-dir "/db.sqlite") + #:schema schema #:path to-register #:references references #:deriver deriver -- cgit v1.2.3 From 866ee8c66aad84fe64a20a14ff19d20a4a408e5b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 22:37:47 +0200 Subject: database: 'register-path' creates the database directory if needed. * guix/store/database.scm (register-path): Call 'mkdir-p'. --- guix/store/database.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 0f6d2e2c06..1400d0d1c4 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -24,6 +24,7 @@ #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix build syscalls) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -268,6 +269,7 @@ be used internally by the daemon's build hook." (let-values (((hash nar-size) (nar-sha256 real-path))) (reset-timestamps real-path) + (mkdir-p db-dir) (sqlite-register #:db-file (string-append db-dir "/db.sqlite") #:schema schema -- cgit v1.2.3 From 0d0438ed8cb744bffa8c7e0a8d60165ce604939f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 16:36:01 +0200 Subject: deduplicate: Fix a couple of thinkos. * guix/store/deduplication.scm (get-temp-link): Turn 'args' in the 'catch' handler into a rest argument. (deduplicate): Use 'lstat' instead of 'file-is-directory?' to properly handle symlinks. When iterating over the result of 'scandir', exclude the ".links" sub-directory. * tests/store-deduplication.scm ("deduplicate"): Create sub-directories and call 'deduplicate' directly on STORE. --- guix/store/deduplication.scm | 13 ++++++++----- tests/store-deduplication.scm | 9 ++++----- 2 files changed, 12 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 4b4ac01f64..d3139eb904 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -85,7 +85,7 @@ LINK-PREFIX." (lambda () (link target tempname) tempname) - (lambda (args) + (lambda args (if (= (system-error-errno args) EEXIST) (try (tempname-in link-prefix)) (throw 'system-error args)))))) @@ -120,12 +120,15 @@ under STORE." (link-file (string-append links-directory "/" (bytevector->base16-string hash)))) (mkdir-p links-directory) - (if (file-is-directory? path) + (if (eq? 'directory (stat:type (lstat path))) ;; Can't hardlink directories, so hardlink their atoms. (for-each (lambda (file) - (unless (member file '("." "..")) - (deduplicate file (nar-sha256 file) - #:store store))) + (unless (or (member file '("." "..")) + (and (string=? path store) + (string=? file ".links"))) + (let ((file (string-append path "/" file))) + (deduplicate file (nar-sha256 file) + #:store store)))) (scandir path)) (if (file-exists? link-file) (false-if-system-error (EMLINK) diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index 04817a193a..2361723199 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -37,10 +37,12 @@ (lambda (store) (let ((data (string->utf8 "Hello, world!")) (identical (map (lambda (n) - (string-append store "/" (number->string n))) + (string-append store "/" (number->string n) + "/a/b/c")) (iota 5))) (unique (string-append store "/unique"))) (for-each (lambda (file) + (mkdir-p (dirname file)) (call-with-output-file file (lambda (port) (put-bytevector port data)))) @@ -49,10 +51,7 @@ (lambda (port) (put-bytevector port (string->utf8 "This is unique.")))) - (for-each (lambda (file) - (deduplicate file (sha256 data) #:store store)) - identical) - (deduplicate unique (nar-sha256 unique) #:store store) + (deduplicate store (nar-sha256 store) #:store store) ;; (system (string-append "ls -lRia " store)) (cons* (apply = (map (compose stat:ino stat) identical)) -- cgit v1.2.3 From b85e2ff4841f1b91c104668bbcf93e39d9792827 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 17:06:05 +0200 Subject: database: Remove extra SQL parameter in 'update-or-insert'. * guix/store/database.scm (update-or-insert): Remove extra #:path parameter. --- guix/store/database.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 1400d0d1c4..b9170dda73 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -127,7 +127,7 @@ of course. Returns the row id of the row that was modified or inserted." (if id (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) (sqlite-bind-arguments stmt #:id id - #:path path #:deriver deriver + #:deriver deriver #:hash hash #:size nar-size #:time time) (sqlite-fold cons '() stmt) (sqlite-finalize stmt) -- cgit v1.2.3 From 4bd86f0d62e948f76536ecfea1225a6e9bfa89c8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 17:06:42 +0200 Subject: database: Add #:reset-timestamps? to 'register-path'. * guix/store/database.scm (register-path): Add #:reset-timestamps? and honor it. --- guix/store/database.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index b9170dda73..bfd2c36264 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -225,6 +225,7 @@ it's a directory." (define* (register-path path #:key (references '()) deriver prefix state-directory (deduplicate? #t) + (reset-timestamps? #t) (schema (sql-schema))) ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and @@ -268,7 +269,8 @@ be used internally by the daemon's build hook." (real-path (string-append store-dir "/" (basename path)))) (let-values (((hash nar-size) (nar-sha256 real-path))) - (reset-timestamps real-path) + (when reset-timestamps? + (reset-timestamps real-path)) (mkdir-p db-dir) (sqlite-register #:db-file (string-append db-dir "/db.sqlite") -- cgit v1.2.3 From 122a6cad7d4a7520593d1dd0c16b3bb8094d7f5a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 17:14:18 +0200 Subject: database: Replace existing entries in Refs. * guix/store/database.scm (add-reference-sql): Add "OR REPLACE". --- guix/store/database.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index bfd2c36264..094dea3ec8 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -141,7 +141,7 @@ of course. Returns the row id of the row that was modified or inserted." (last-insert-row-id db))))) (define add-reference-sql - "INSERT INTO Refs (referrer, reference) VALUES (:referrer, :reference);") + "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);") (define (add-references db referrer references) "REFERRER is the id of the referring store item, REFERENCES is a list -- cgit v1.2.3 From 49c393ccaae99dbddffcbebac73ecabeacd1bc9b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 22:53:52 +0200 Subject: database: 'reset-timestamps' sets file permissions as well. * guix/store/database.scm (reset-timestamps): Add 'chmod' calls. --- guix/store/database.scm | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 094dea3ec8..67dfb8b0ee 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -24,7 +24,8 @@ #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix build syscalls) - #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build utils) + #:select (mkdir-p executable-file?)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -189,11 +190,12 @@ Every store item in REFERENCES must already be registered." ;; TODO: Factorize with that in (gnu build install). (define (reset-timestamps file) "Reset the modification time on FILE and on all the files it contains, if -it's a directory." +it's a directory. While at it, canonicalize file permissions." (let loop ((file file) (type (stat:type (lstat file)))) (case type ((directory) + (chmod file #o555) (utime file 0 0 0 0) (let ((parent file)) (for-each (match-lambda @@ -212,16 +214,9 @@ it's a directory." ;; symlinks. #f) (else + (chmod file (if (executable-file? file) #o555 #o444)) (utime file 0 0 0 0))))) -;; TODO: make this canonicalize store items that are registered. This involves -;; setting permissions and timestamps, I think. Also, run a "deduplication -;; pass", whatever that involves. Also, handle databases not existing yet -;; (what should the default behavior be? Figuring out how the C++ stuff -;; currently does it sounds like a lot of grepping for global -;; variables...). Also, return #t on success like the documentation says we -;; should. - (define* (register-path path #:key (references '()) deriver prefix state-directory (deduplicate? #t) -- cgit v1.2.3 From c45477d2a1a651485feede20fe0f3d15aec48b39 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 23:58:18 +0200 Subject: install: Use (guix store database) instead of 'guix-register'. * gnu/build/install.scm (register-closure): Add #:reset-timestamps? and and #:schema; honor them. Rewrite in terms of 'register-path'. (populate-single-profile-directory): Add #:schema and honor it. Make /var/guix/profiles and /var/guix/gcroots. * gnu/build/vm.scm (root-partition-initializer): Pass #:reset-timestamps? to 'register-closure'. * gnu/system/vm.scm (not-config?): New procedure. (guile-sqlite3&co): New variable. (expression->derivation-in-linux-vm)[config]: New variable. [builder]: Use 'with-extensions'. (iso9660-image)[schema, config]: New variables. Wrap build expression in 'with-extensions'; add 'sql-schema' call. Remove GUIX from INPUTS. (qemu-image)[schema, config]: New variables. Wrap body in 'with-extensions'. (system-docker-image)[not-config?]: Remove. [config]: Use 'make-config.scm'. [schema]: New variable. [build]: Use 'with-extensions'. Add call to 'sql-schema'. Remove GUIX from INPUTS. * gnu/system/file-systems.scm (%store-prefix): Check whether '%store-prefix' is defined. * guix/scripts/pack.scm (self-contained-tarball)[not-config?] [libgcrypt, schema]: New variables. [build]: Wrap in 'with-extensions'. Adjust imported module list to use 'make-config.scm' for (guix config). --- gnu/build/install.scm | 45 +++-- gnu/build/vm.scm | 1 + gnu/system/file-systems.scm | 11 +- gnu/system/vm.scm | 391 ++++++++++++++++++++++++-------------------- guix/scripts/pack.scm | 233 ++++++++++++++------------ 5 files changed, 379 insertions(+), 302 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 9e30c0d23e..6cc678b44b 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich ;;; ;;; This file is part of GNU Guix. @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build install) + #:use-module (guix store database) #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-26) @@ -158,23 +159,31 @@ as created and modified at the Epoch." (utime file 0 0 0 0)))) (find-files directory #:directories? #t))) -(define* (register-closure store closure - #:key (deduplicate? #t)) - "Register CLOSURE in STORE, where STORE is the directory name of the target -store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'. As a side effect, this resets timestamps on store files -and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the -rest of STORE." - (let ((status (apply system* "guix-register" "--prefix" store - (append (if deduplicate? '() '("--no-deduplication")) - (list closure))))) - (unless (zero? status) - (error "failed to register store items" closure)))) +(define* (register-closure prefix closure + #:key + (deduplicate? #t) (reset-timestamps? #t) + (schema (sql-schema))) + "Register CLOSURE in PREFIX, where PREFIX is the directory name of the +target store and CLOSURE is the name of a file containing a reference graph as +produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is +true, reset timestamps on store files and, if DEDUPLICATE? is true, +deduplicates files common to CLOSURE and the rest of PREFIX." + (let ((items (call-with-input-file closure read-reference-graph))) + ;; TODO: Add a procedure to register all of ITEMS at once. + (for-each (lambda (item) + (register-path (store-info-item item) + #:references (store-info-references item) + #:deriver (store-info-deriver item) + #:prefix prefix + #:deduplicate? deduplicate? + #:reset-timestamps? reset-timestamps? + #:schema schema)) + items))) (define* (populate-single-profile-directory directory #:key profile closure deduplicate? - register?) + register? schema) "Populate DIRECTORY with a store containing PROFILE, whose closure is given in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY is initialized to contain a single profile under /root pointing to PROFILE. @@ -200,11 +209,11 @@ This is used to create the self-contained tarballs with 'guix pack'." (when register? (register-closure (canonicalize-path directory) closure - #:deduplicate? deduplicate?) + #:deduplicate? deduplicate? + #:schema schema) - ;; XXX: 'guix-register' registers profiles as GC roots but the symlink - ;; target uses $TMPDIR. Fix that. - (delete-file (scope "/var/guix/gcroots/profiles")) + (mkdir-p* "/var/guix/profiles") + (mkdir-p* "/var/guix/gcroots") (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index fa3ce7790d..37639f723a 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -354,6 +354,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (for-each (lambda (closure) (register-closure target (string-append "/xchg/" closure) + #:reset-timestamps? copy-closures? #:deduplicate? deduplicate?)) closures) (unless copy-closures? diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 2b5948256a..393dd0df70 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -194,10 +194,15 @@ ;; differs from user to user. (define (%store-prefix) "Return the store prefix." - (cond ((resolve-module '(guix store) #:ensure #f) + ;; Note: If we have (guix store database) in the search path and we do *not* + ;; have (guix store) proper, 'resolve-module' returns an empty (guix store) + ;; with one sub-module. + (cond ((and=> (resolve-module '(guix store) #:ensure #f) + (lambda (store) + (module-variable store '%store-prefix))) => - (lambda (store) - ((module-ref store '%store-prefix)))) + (lambda (variable) + ((variable-ref variable)))) ((getenv "NIX_STORE") => identity) (else diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 94f1c6197a..b505b0cf6b 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -34,6 +34,7 @@ #:use-module (guix utils) #:use-module (guix hash) #:use-module (guix base32) + #:use-module ((guix self) #:select (make-config.scm)) #:use-module ((gnu build vm) #:select (qemu-command)) @@ -50,7 +51,6 @@ #:use-module (gnu packages disk) #:use-module (gnu packages zile) #:use-module (gnu packages linux) - #:use-module (gnu packages package-management) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) #:use-module (gnu packages admin) @@ -116,6 +116,19 @@ (options "trans=virtio") (check? #f)))) +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + +(define guile-sqlite3&co + ;; Guile-SQLite3 and its propagated inputs. + (cons guile-sqlite3 + (package-transitive-propagated-inputs guile-sqlite3))) + (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) @@ -151,6 +164,10 @@ based on the size of the closure of REFERENCES-GRAPHS. When REFERENCES-GRAPHS is true, it must be a list of file name/store path pairs, as for `derivation'. The files containing the reference graphs are made available under the /xchg CIFS share." + (define config + ;; (guix config) module for consumption by (guix gcrypt). + (make-config.scm #:libgcrypt libgcrypt)) + (define user-builder (program-file "builder-in-linux-vm" exp)) @@ -178,40 +195,44 @@ made available under the /xchg CIFS share." (define builder ;; Code that launches the VM that evaluates EXP. - (with-imported-modules (source-module-closure '((guix build utils) - (gnu build vm))) - #~(begin - (use-modules (guix build utils) - (gnu build vm)) - - (let* ((inputs '#$(list qemu coreutils)) - (linux (string-append #$linux "/" - #$(system-linux-image-file-name))) - (initrd (string-append #$initrd "/initrd")) - (loader #$loader) - (graphs '#$(match references-graphs - (((graph-files . _) ...) graph-files) - (_ #f))) - (size #$(if (eq? 'guess disk-image-size) - #~(+ (* 70 (expt 2 20)) ;ESP - (estimated-partition-size graphs)) - disk-image-size))) - - (set-path-environment-variable "PATH" '("bin") inputs) - - (load-in-linux-vm loader - #:output #$output - #:linux linux #:initrd initrd - #:memory-size #$memory-size - #:make-disk-image? #$make-disk-image? - #:single-file-output? #$single-file-output? - ;; FIXME: ‘target-arm32?’ may not operate on - ;; the right system/target values. Rewrite - ;; using ‘let-system’ when available. - #:target-arm32? #$(target-arm32?) - #:disk-image-format #$disk-image-format - #:disk-image-size size - #:references-graphs graphs))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure + '((guix build utils) + (gnu build vm)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (guix build utils) + (gnu build vm)) + + (let* ((inputs '#$(list qemu (canonical-package coreutils))) + (linux (string-append #$linux "/" + #$(system-linux-image-file-name))) + (initrd (string-append #$initrd "/initrd")) + (loader #$loader) + (graphs '#$(match references-graphs + (((graph-files . _) ...) graph-files) + (_ #f))) + (size #$(if (eq? 'guess disk-image-size) + #~(+ (* 70 (expt 2 20)) ;ESP + (estimated-partition-size graphs)) + disk-image-size))) + + (set-path-environment-variable "PATH" '("bin") inputs) + + (load-in-linux-vm loader + #:output #$output + #:linux linux #:initrd initrd + #:memory-size #$memory-size + #:make-disk-image? #$make-disk-image? + #:single-file-output? #$single-file-output? + ;; FIXME: ‘target-arm32?’ may not operate on + ;; the right system/target values. Rewrite + ;; using ‘let-system’ when available. + #:target-arm32? #$(target-arm32?) + #:disk-image-format #$disk-image-format + #:disk-image-size size + #:references-graphs graphs)))))) (gexp->derivation name builder ;; TODO: Require the "kvm" feature. @@ -234,42 +255,56 @@ made available under the /xchg CIFS share." "Return a bootable, stand-alone iso9660 image. INPUTS is a list of inputs (as for packages)." + (define config + (make-config.scm #:libgcrypt libgcrypt)) + + (define schema + (and register-closures? + (local-file (search-path %load-path + "guix/store/schema.sql")))) + (expression->derivation-in-linux-vm name - (with-imported-modules (source-module-closure '((gnu build vm) - (guix build utils))) - #~(begin - (use-modules (gnu build vm) - (guix build utils)) - - (let ((inputs - '#$(append (list qemu parted e2fsprogs dosfstools xorriso) - (map canonical-package - (list sed grep coreutils findutils gawk)) - (if register-closures? (list guix) '()))) - - - (graphs '#$(match inputs - (((names . _) ...) - names))) - ;; This variable is unused but allows us to add INPUTS-TO-COPY - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (make-iso9660-image #$(bootloader-package bootloader) - #$bootcfg-drv - #$os-drv - "/xchg/guixsd.iso" - #:register-closures? #$register-closures? - #:closures graphs - #:volume-id #$file-system-label - #:volume-uuid #$(and=> file-system-uuid - uuid-bytevector))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure '((gnu build vm) + (guix store database) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (gnu build vm) + (guix store database) + (guix build utils)) + + (sql-schema #$schema) + + (let ((inputs + '#$(append (list qemu parted e2fsprogs dosfstools xorriso) + (map canonical-package + (list sed grep coreutils findutils gawk)))) + + + (graphs '#$(match inputs + (((names . _) ...) + names))) + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-register + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (make-iso9660-image #$(bootloader-package bootloader) + #$bootcfg-drv + #$os-drv + "/xchg/guixsd.iso" + #:register-closures? #$register-closures? + #:closures graphs + #:volume-id #$file-system-label + #:volume-uuid #$(and=> file-system-uuid + uuid-bytevector)))))) #:system system ;; Keep a local file system for /tmp so that we can populate it directly as @@ -312,90 +347,104 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in the image." + (define config + (make-config.scm #:libgcrypt libgcrypt)) + + (define schema + (and register-closures? + (local-file (search-path %load-path + "guix/store/schema.sql")))) + (expression->derivation-in-linux-vm name - (with-imported-modules (source-module-closure '((gnu build bootloader) - (gnu build vm) - (guix build utils))) - #~(begin - (use-modules (gnu build bootloader) - (gnu build vm) - (guix build utils) - (srfi srfi-26) - (ice-9 binary-ports)) - - (let ((inputs - '#$(append (list qemu parted e2fsprogs dosfstools) - (map canonical-package - (list sed grep coreutils findutils gawk)) - (if register-closures? (list guix) '()))) - - ;; This variable is unused but allows us to add INPUTS-TO-COPY - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - - (let* ((graphs '#$(match inputs - (((names . _) ...) - names))) - (initialize (root-partition-initializer - #:closures graphs - #:copy-closures? #$copy-inputs? - #:register-closures? #$register-closures? - #:system-directory #$os-drv)) - (root-size #$(if (eq? 'guess disk-image-size) - #~(max - ;; Minimum 20 MiB root size - (* 20 (expt 2 20)) - (estimated-partition-size - (map (cut string-append "/xchg/" <>) - graphs))) - (- disk-image-size - (* 50 (expt 2 20))))) - (partitions - (append - (list (partition - (size root-size) - (label #$file-system-label) - (uuid #$(and=> file-system-uuid - uuid-bytevector)) - (file-system #$file-system-type) - (flags '(boot)) - (initializer initialize))) - ;; Append a small EFI System Partition for use with UEFI - ;; bootloaders if we are not targeting ARM because UEFI - ;; support in U-Boot is experimental. - ;; - ;; FIXME: ‘target-arm32?’ may be not operate on the right - ;; system/target values. Rewrite using ‘let-system’ when - ;; available. - (if #$(target-arm32?) - '() - (list (partition - ;; The standalone grub image is about 10MiB, but - ;; leave some room for custom or multiple images. - (size (* 40 (expt 2 20))) - (label "GNU-ESP") ;cosmetic only - ;; Use "vfat" here since this property is used - ;; when mounting. The actual FAT-ness is based - ;; on file system size (16 in this case). - (file-system "vfat") - (flags '(esp)))))))) - (initialize-hard-disk "/dev/vda" - #:partitions partitions - #:grub-efi #$grub-efi - #:bootloader-package - #$(bootloader-package bootloader) - #:bootcfg #$bootcfg-drv - #:bootcfg-location - #$(bootloader-configuration-file bootloader) - #:bootloader-installer - #$(bootloader-installer bootloader)))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure '((gnu build vm) + (gnu build bootloader) + (guix store database) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (gnu build bootloader) + (gnu build vm) + (guix store database) + (guix build utils) + (srfi srfi-26) + (ice-9 binary-ports)) + + (sql-schema #$schema) + + (let ((inputs + '#$(append (list qemu parted e2fsprogs dosfstools) + (map canonical-package + (list sed grep coreutils findutils gawk)))) + + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-register + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + (let* ((graphs '#$(match inputs + (((names . _) ...) + names))) + (initialize (root-partition-initializer + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? + #:system-directory #$os-drv)) + (root-size #$(if (eq? 'guess disk-image-size) + #~(max + ;; Minimum 20 MiB root size + (* 20 (expt 2 20)) + (estimated-partition-size + (map (cut string-append "/xchg/" <>) + graphs))) + (- disk-image-size + (* 50 (expt 2 20))))) + (partitions + (append + (list (partition + (size root-size) + (label #$file-system-label) + (uuid #$(and=> file-system-uuid + uuid-bytevector)) + (file-system #$file-system-type) + (flags '(boot)) + (initializer initialize))) + ;; Append a small EFI System Partition for use with UEFI + ;; bootloaders if we are not targeting ARM because UEFI + ;; support in U-Boot is experimental. + ;; + ;; FIXME: ‘target-arm32?’ may be not operate on the right + ;; system/target values. Rewrite using ‘let-system’ when + ;; available. + (if #$(target-arm32?) + '() + (list (partition + ;; The standalone grub image is about 10MiB, but + ;; leave some room for custom or multiple images. + (size (* 40 (expt 2 20))) + (label "GNU-ESP") ;cosmetic only + ;; Use "vfat" here since this property is used + ;; when mounting. The actual FAT-ness is based + ;; on file system size (16 in this case). + (file-system "vfat") + (flags '(esp)))))))) + (initialize-hard-disk "/dev/vda" + #:partitions partitions + #:grub-efi #$grub-efi + #:bootloader-package + #$(bootloader-package bootloader) + #:bootcfg #$bootcfg-drv + #:bootcfg-location + #$(bootloader-configuration-file bootloader) + #:bootloader-installer + #$(bootloader-installer bootloader))))))) #:system system #:make-disk-image? #t #:disk-image-size disk-image-size @@ -413,49 +462,41 @@ makes sense when you want to build a GuixSD Docker image that has Guix installed inside of it. If you don't need Guix (e.g., your GuixSD Docker image just contains a web server that is started by the Shepherd), then you should set REGISTER-CLOSURES? to #f." - (define not-config? - (match-lambda - (('guix 'config) #f) - (('guix rest ...) #t) - (('gnu rest ...) #t) - (rest #f))) - (define config ;; (guix config) module for consumption by (guix gcrypt). - (scheme-file "gcrypt-config.scm" - #~(begin - (define-module (guix config) - #:export (%libgcrypt)) + (make-config.scm #:libgcrypt libgcrypt)) - ;; XXX: Work around . - (eval-when (expand load eval) - (define %libgcrypt - #+(file-append libgcrypt "/lib/libgcrypt")))))) + (define schema + (and register-closures? + (local-file (search-path %load-path + "guix/store/schema.sql")))) (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (name -> (string-append name ".tar.gz")) (graph -> "system-graph")) (define build - (with-extensions (list guile-json) ;for (guix docker) + (with-extensions (cons guile-json ;for (guix docker) + guile-sqlite3&co) ;for (guix store database) (with-imported-modules `(,@(source-module-closure '((guix docker) + (guix store database) (guix build utils) + (guix build store-copy) (gnu build vm)) #:select? not-config?) - (guix build store-copy) ((guix config) => ,config)) #~(begin (use-modules (guix docker) (guix build utils) (gnu build vm) (srfi srfi-19) - (guix build store-copy)) + (guix build store-copy) + (guix store database)) + + ;; Set the SQL schema location. + (sql-schema #$schema) - (let* ((inputs '#$(append (list tar) - (if register-closures? - (list guix) - '()))) - ;; This initializer requires elevated privileges that are + (let* (;; This initializer requires elevated privileges that are ;; not normally available in the build environment (e.g., ;; it needs to create device nodes). In order to obtain ;; such privileges, we run it as root in a VM. @@ -470,7 +511,7 @@ should set REGISTER-CLOSURES? to #f." ;; lack of privileges if we use a root-directory that is on ;; a file system that is shared with the host (e.g., /tmp). (root-directory "/guixsd-system-root")) - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar)) (mkdir root-directory) (initialize root-directory) (build-docker-image diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78bfd01eff..ed876b2592 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -35,6 +35,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system gnu) #:use-module (guix scripts build) + #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (gnu packages compression) @@ -101,113 +102,133 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define build - (with-imported-modules (source-module-closure - '((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install))) - #~(begin - (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (define not-config? + (match-lambda + (('guix 'config) #f) + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) - (define %root "root") - - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownnership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) - - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) - - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. For testing, we use the bootstrap tar, which is - ;; older and doesn't support it. - (define tar-supports-sort? - (zero? (system* (string-append #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - ;; We need Guix here for 'guix-register'. - (setenv "PATH" - (string-append #$(if localstatedir? - (file-append guix "/sbin:") - "") - #$archiver "/bin")) - - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; . - (populate-single-profile-directory %root - #:profile #$profile - #:closure "profile" - #:deduplicate? #f - #:register? #$localstatedir?) - - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (exit - (zero? (apply system* "tar" - "-I" - (string-join '#+(compressor-command compressor)) - "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) - - (string-append "." (%store-directory)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives))))))))) + (define libgcrypt + (module-ref (resolve-interface '(gnu packages gnupg)) + 'libgcrypt)) + + (define schema + (and localstatedir? + (local-file (search-path %load-path + "guix/store/schema.sql")))) + + (define build + (with-imported-modules `(((guix config) + => ,(make-config.scm + #:libgcrypt libgcrypt)) + ,@(source-module-closure + `((guix build utils) + (guix build union) + (guix build store-copy) + (gnu build install)) + #:select? not-config?)) + (with-extensions (cons guile-sqlite3 + (package-transitive-propagated-inputs + guile-sqlite3)) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define %root "root") + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append archiver "/bin")) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; . + (populate-single-profile-directory %root + #:profile #$profile + #:closure "profile" + #:deduplicate? #f + #:register? #$localstatedir? + #:schema #$schema) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (exit + (zero? (apply system* "tar" + "-I" + (string-join '#+(compressor-command compressor)) + "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) + + (string-append "." (%store-directory)) + + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives)))))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) -- cgit v1.2.3 From ef1297e8c74a0358d2538a5dd43d50cde7bf14a3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Jun 2018 21:55:15 +0200 Subject: database: 'sqlite-register' takes a database, not a file name. * guix/store/database.scm (sqlite-register): Remove #:db-file and add 'db' parameter. Remove #:schema and 'parameterize'. (register-path): Wrap 'sqlite-register' call in 'with-database' and in 'parameterize'. * tests/store-database.scm ("new database") ("register-path with unregistered references"): Adjust accordingly. --- guix/store/database.scm | 57 ++++++++++++++++++++++-------------------------- tests/store-database.scm | 40 ++++++++++++++++----------------- 2 files changed, 46 insertions(+), 51 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 67dfb8b0ee..1e5e3bcc71 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -157,30 +157,24 @@ ids of items referred to." (last-insert-row-id db)) references))) -;; XXX figure out caching of statement and database objects... later -(define* (sqlite-register #:key db-file path (references '()) - deriver hash nar-size - (schema (sql-schema))) - "Registers this stuff in a database specified by DB-FILE. PATH is the string -path of some store item, REFERENCES is a list of string paths which the store -item PATH refers to (they need to be already registered!), DERIVER is a string -path of the derivation that created the store item PATH, HASH is the -base16-encoded sha256 hash of the store item denoted by PATH (prefixed with -\"sha256:\") after being converted to nar form, and NAR-SIZE is the size in -bytes of the store item denoted by PATH after being converted to nar form. +(define* (sqlite-register db #:key path (references '()) + deriver hash nar-size) + "Registers this stuff in DB. PATH is the store item to register and +REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv' +that produced PATH, HASH is the base16-encoded Nix sha256 hash of +PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after +being converted to nar form. Every store item in REFERENCES must already be registered." - (parameterize ((sql-schema schema)) - (with-database db-file db - (let ((id (update-or-insert db #:path path - #:deriver deriver - #:hash hash - #:nar-size nar-size - #:time (time-second (current-time time-utc))))) - ;; Call 'path-id' on each of REFERENCES. This ensures we get a - ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. - (add-references db id - (map (cut path-id db <>) references)))))) + (let ((id (update-or-insert db #:path path + #:deriver deriver + #:hash hash + #:nar-size nar-size + #:time (time-second (current-time time-utc))))) + ;; Call 'path-id' on each of REFERENCES. This ensures we get a + ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. + (add-references db id + (map (cut path-id db <>) references)))) ;;; @@ -267,15 +261,16 @@ be used internally by the daemon's build hook." (when reset-timestamps? (reset-timestamps real-path)) (mkdir-p db-dir) - (sqlite-register - #:db-file (string-append db-dir "/db.sqlite") - #:schema schema - #:path to-register - #:references references - #:deriver deriver - #:hash (string-append "sha256:" - (bytevector->base16-string hash)) - #:nar-size nar-size) + (parameterize ((sql-schema schema)) + (with-database (string-append db-dir "/db.sqlite") db + (sqlite-register + db + #:path to-register + #:references references + #:deriver deriver + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size))) (when deduplicate? (deduplicate real-path hash #:store store-dir))))) diff --git a/tests/store-database.scm b/tests/store-database.scm index 9562055fd1..22c356679b 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -57,20 +57,20 @@ (call-with-temporary-output-file (lambda (db-file port) (delete-file db-file) - (sqlite-register #:db-file db-file - #:path "/gnu/foo" - #:references '() - #:deriver "/gnu/foo.drv" - #:hash (string-append "sha256:" (make-string 64 #\e)) - #:nar-size 1234) - (sqlite-register #:db-file db-file - #:path "/gnu/bar" - #:references '("/gnu/foo") - #:deriver "/gnu/bar.drv" - #:hash (string-append "sha256:" (make-string 64 #\a)) - #:nar-size 4321) - (let ((path-id (@@ (guix store database) path-id))) - (with-database db-file db + (with-database db-file db + (sqlite-register db + #:path "/gnu/foo" + #:references '() + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size 1234) + (sqlite-register db + #:path "/gnu/bar" + #:references '("/gnu/foo") + #:deriver "/gnu/bar.drv" + #:hash (string-append "sha256:" (make-string 64 #\a)) + #:nar-size 4321) + (let ((path-id (@@ (guix store database) path-id))) (list (path-id db "/gnu/foo") (path-id db "/gnu/bar"))))))) @@ -83,12 +83,12 @@ (delete-file db-file) (catch 'sqlite-error (lambda () - (sqlite-register #:db-file db-file - #:path "/gnu/foo" - #:references '("/gnu/bar") - #:deriver "/gnu/foo.drv" - #:hash (string-append "sha256:" (make-string 64 #\e)) - #:nar-size 1234) + (with-database db-file db + (sqlite-register db #:path "/gnu/foo" + #:references '("/gnu/bar") + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size 1234)) #f) (lambda args (pk 'welcome-exception! args) -- cgit v1.2.3 From 31a63be8784b2769c2db21388f788a8b975fd4e1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Jun 2018 22:23:57 +0200 Subject: database: Add 'register-items'. * guix/build/store-copy.scm (store-info): Export. * guix/store/database.scm (register-items): New procedure. (register-path): Implement in terms of 'register-items'. * gnu/build/install.scm (register-closure): Use 'register-items' instead of 'for-each' and 'register-path'. --- gnu/build/install.scm | 15 ++---- guix/build/store-copy.scm | 1 + guix/store/database.scm | 113 +++++++++++++++++++++++++++------------------- 3 files changed, 72 insertions(+), 57 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 6cc678b44b..82eb63d726 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -169,16 +169,11 @@ produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is true, reset timestamps on store files and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the rest of PREFIX." (let ((items (call-with-input-file closure read-reference-graph))) - ;; TODO: Add a procedure to register all of ITEMS at once. - (for-each (lambda (item) - (register-path (store-info-item item) - #:references (store-info-references item) - #:deriver (store-info-deriver item) - #:prefix prefix - #:deduplicate? deduplicate? - #:reset-timestamps? reset-timestamps? - #:schema schema)) - items))) + (register-items items + #:prefix prefix + #:deduplicate? deduplicate? + #:reset-timestamps? reset-timestamps? + #:schema schema))) (define* (populate-single-profile-directory directory #:key profile closure diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index bad1c09cba..2d9590d16f 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -27,6 +27,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 vlist) #:export (store-info? + store-info store-info-item store-info-deriver store-info-references diff --git a/guix/store/database.scm b/guix/store/database.scm index 1e5e3bcc71..3dbe5270a3 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -26,6 +26,7 @@ #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (mkdir-p executable-file?)) + #:use-module (guix build store-copy) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -37,6 +38,7 @@ with-database sqlite-register register-path + register-items reset-timestamps)) ;;; Code for working with the store database directly. @@ -216,11 +218,6 @@ it's a directory. While at it, canonicalize file permissions." state-directory (deduplicate? #t) (reset-timestamps? #t) (schema (sql-schema))) - ;; Priority for options: first what is given, then environment variables, - ;; then defaults. %state-directory, %store-directory, and - ;; %store-database-directory already handle the "environment variables / - ;; defaults" question, so we only need to choose between what is given and - ;; those. "Register PATH as a valid store file, with REFERENCES as its list of references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is given, it must be the name of the directory containing the new store to @@ -230,47 +227,69 @@ Return #t on success. Use with care as it directly modifies the store! This is primarily meant to be used internally by the daemon's build hook." - (let* ((db-dir (cond - (state-directory - (string-append state-directory "/db")) - (prefix - ;; If prefix is specified, the value of NIX_STATE_DIR - ;; (which affects %state-directory) isn't supposed to - ;; affect db-dir, only the compile-time-customized - ;; default should. - (string-append prefix %localstatedir "/guix/db")) - (else - %store-database-directory))) - (store-dir (if prefix - ;; same situation as above - (string-append prefix %storedir) - %store-directory)) - (to-register (if prefix - (string-append %storedir "/" (basename path)) - ;; note: we assume here that if path is, for - ;; example, /foo/bar/gnu/store/thing.txt and prefix - ;; isn't given, then an environment variable has - ;; been used to change the store directory to - ;; /foo/bar/gnu/store, since otherwise real-path - ;; would end up being /gnu/store/thing.txt, which is - ;; probably not the right file in this case. - path)) - (real-path (string-append store-dir "/" (basename path)))) - (let-values (((hash nar-size) - (nar-sha256 real-path))) - (when reset-timestamps? - (reset-timestamps real-path)) - (mkdir-p db-dir) - (parameterize ((sql-schema schema)) - (with-database (string-append db-dir "/db.sqlite") db - (sqlite-register - db - #:path to-register - #:references references - #:deriver deriver - #:hash (string-append "sha256:" - (bytevector->base16-string hash)) - #:nar-size nar-size))) + (register-items (list (store-info path deriver references)) + #:prefix prefix #:state-directory state-directory + #:deduplicate? deduplicate? + #:reset-timestamps? reset-timestamps? + #:schema schema)) + +(define* (register-items items + #:key prefix state-directory + (deduplicate? #t) + (reset-timestamps? #t) + (schema (sql-schema))) + "Register all of ITEMS, a list of records as returned by +'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS +must be in topological order (with leaves first.) If the database is +initially empty, apply SCHEMA to initialize it." + ;; Priority for options: first what is given, then environment variables, + ;; then defaults. %state-directory, %store-directory, and + ;; %store-database-directory already handle the "environment variables / + ;; defaults" question, so we only need to choose between what is given and + ;; those. + + (define db-dir + (cond (state-directory + (string-append state-directory "/db")) + (prefix + (string-append prefix %localstatedir "/guix/db")) + (else + %store-database-directory))) + + (define store-dir + (if prefix + (string-append prefix %storedir) + %store-directory)) + + (define (register db item) + (define to-register + (if prefix + (string-append %storedir "/" (basename (store-info-item item))) + ;; note: we assume here that if path is, for example, + ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an + ;; environment variable has been used to change the store directory + ;; to /foo/bar/gnu/store, since otherwise real-path would end up + ;; being /gnu/store/thing.txt, which is probably not the right file + ;; in this case. + (store-info-item item))) + + (define real-file-name + (string-append store-dir "/" (basename (store-info-item item)))) + + (let-values (((hash nar-size) (nar-sha256 real-file-name))) + (when reset-timestamps? + (reset-timestamps real-file-name)) + (sqlite-register db #:path to-register + #:references (store-info-references item) + #:deriver (store-info-deriver item) + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size) (when deduplicate? - (deduplicate real-path hash #:store store-dir))))) + (deduplicate real-file-name hash #:store store-dir)))) + + (mkdir-p db-dir) + (parameterize ((sql-schema schema)) + (with-database (string-append db-dir "/db.sqlite") db + (for-each (cut register db <>) items)))) -- cgit v1.2.3 From 078c2329c0ffc88ac8e334fcea5e025ee6410e62 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Jun 2018 22:35:36 +0200 Subject: install: Use 'reset-timestamps' from (guix store database). * gnu/build/install.scm (reset-timestamps): Remove. * gnu/build/vm.scm: Use 'reset-timestamps' from (guix store database). --- gnu/build/install.scm | 15 --------------- gnu/build/vm.scm | 1 + guix/store/database.scm | 1 - 3 files changed, 1 insertion(+), 16 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 82eb63d726..5e84cd6f69 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -26,7 +26,6 @@ #:export (install-boot-config evaluate-populate-directive populate-root-file-system - reset-timestamps register-closure populate-single-profile-directory)) @@ -145,20 +144,6 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM." (try)) (apply throw args))))))) -(define (reset-timestamps directory) - "Reset the timestamps of all the files under DIRECTORY, so that they appear -as created and modified at the Epoch." - (display "clearing file timestamps...\n") - (for-each (lambda (file) - (let ((s (lstat file))) - ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so - ;; the timestamp of symlinks cannot be changed, and there are - ;; symlinks here pointing to /gnu/store, which is the host, - ;; read-only store. - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files directory #:directories? #t))) - (define* (register-closure prefix closure #:key (deduplicate? #t) (reset-timestamps? #t) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 37639f723a..803cd5996a 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -25,6 +25,7 @@ #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (guix build syscalls) + #:use-module ((guix store database) #:select (reset-timestamps)) #:use-module (gnu build linux-boot) #:use-module (gnu build install) #:use-module (gnu system uuid) diff --git a/guix/store/database.scm b/guix/store/database.scm index 3dbe5270a3..82938455ba 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -183,7 +183,6 @@ Every store item in REFERENCES must already be registered." ;;; High-level interface. ;;; -;; TODO: Factorize with that in (gnu build install). (define (reset-timestamps file) "Reset the modification time on FILE and on all the files it contains, if it's a directory. While at it, canonicalize file permissions." -- cgit v1.2.3 From eb9fe97495c012c989f76cb42a14cd78f9d94629 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jun 2018 00:00:47 +0200 Subject: database: Allow for deterministic database construction. Fixes . * guix/store/database.scm (sqlite-register): Add #:time. (%epoch): New variable. (register-items): Add #:registration-time. Pass #:time to 'sqlite-register'. * gnu/build/install.scm (register-closure): Pass #:registration-time. --- gnu/build/install.scm | 1 + guix/store/database.scm | 21 ++++++++++++++++----- 2 files changed, 17 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 5e84cd6f69..06ecb39952 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -158,6 +158,7 @@ deduplicates files common to CLOSURE and the rest of PREFIX." #:prefix prefix #:deduplicate? deduplicate? #:reset-timestamps? reset-timestamps? + #:registration-time %epoch #:schema schema))) (define* (populate-single-profile-directory directory diff --git a/guix/store/database.scm b/guix/store/database.scm index 82938455ba..05b2ba6c3f 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -39,6 +39,7 @@ sqlite-register register-path register-items + %epoch reset-timestamps)) ;;; Code for working with the store database directly. @@ -160,19 +161,22 @@ ids of items referred to." references))) (define* (sqlite-register db #:key path (references '()) - deriver hash nar-size) + deriver hash nar-size time) "Registers this stuff in DB. PATH is the store item to register and REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv' that produced PATH, HASH is the base16-encoded Nix sha256 hash of PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after -being converted to nar form. +being converted to nar form. TIME is the registration time to be recorded in +the database or #f, meaning \"right now\". Every store item in REFERENCES must already be registered." (let ((id (update-or-insert db #:path path #:deriver deriver #:hash hash #:nar-size nar-size - #:time (time-second (current-time time-utc))))) + #:time (time-second + (or time + (current-time time-utc)))))) ;; Call 'path-id' on each of REFERENCES. This ensures we get a ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. (add-references db id @@ -232,15 +236,21 @@ be used internally by the daemon's build hook." #:reset-timestamps? reset-timestamps? #:schema schema)) +(define %epoch + ;; When it all began. + (make-time time-utc 0 1)) + (define* (register-items items #:key prefix state-directory (deduplicate? #t) (reset-timestamps? #t) + registration-time (schema (sql-schema))) "Register all of ITEMS, a list of records as returned by 'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS must be in topological order (with leaves first.) If the database is -initially empty, apply SCHEMA to initialize it." +initially empty, apply SCHEMA to initialize it. REGISTRATION-TIME must be the +registration time to be recorded in the database; #f means \"now\"." ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and @@ -284,7 +294,8 @@ initially empty, apply SCHEMA to initialize it." #:deriver (store-info-deriver item) #:hash (string-append "sha256:" (bytevector->base16-string hash)) - #:nar-size nar-size) + #:nar-size nar-size + #:time registration-time) (when deduplicate? (deduplicate real-file-name hash #:store store-dir)))) -- cgit v1.2.3 From df2f6400b1fbc282ef4d6dd7124ea1c17adc23c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jun 2018 10:56:19 +0200 Subject: store: Remove 'register-path'. * guix/store.scm (register-path): Remove. * guix/nar.scm: Use (guix store database). * guix/scripts/system.scm: Likewise. * tests/store-database.scm: Remove #:hide (register-path). * tests/store.scm ("register-path"): Remove. --- guix/nar.scm | 3 ++- guix/scripts/system.scm | 1 + guix/store.scm | 29 ----------------------------- tests/store-database.scm | 2 +- tests/store.scm | 22 +--------------------- 5 files changed, 5 insertions(+), 52 deletions(-) (limited to 'guix') diff --git a/guix/nar.scm b/guix/nar.scm index 9b4c608238..3556de1379 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès ;;; Copyright © 2014 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -23,6 +23,7 @@ #:use-module ((guix build utils) #:select (delete-file-recursively with-directory-excursion)) #:use-module (guix store) + #:use-module (guix store database) #:use-module (guix ui) ; for '_' #:use-module (guix hash) #:use-module (guix pki) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 14be8ff8cf..9112177bfb 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -23,6 +23,7 @@ #:use-module (guix config) #:use-module (guix ui) #:use-module (guix store) + #:autoload (guix store database) (register-path) #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) diff --git a/guix/store.scm b/guix/store.scm index 6742611c6f..773d53e82b 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -122,8 +122,6 @@ current-build-output-port - register-path - %store-monad store-bind store-return @@ -1301,33 +1299,6 @@ The result is always the empty list unless the daemon was started with This makes sense only when the daemon was started with '--cache-failures'." boolean) -(define* (register-path path - #:key (references '()) deriver prefix - state-directory) - "Register PATH as a valid store file, with REFERENCES as its list of -references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is -not #f, it must be the name of the directory containing the new store to -initialize; if STATE-DIRECTORY is not #f, it must be a string containing the -absolute file name to the state directory of the store being initialized. -Return #t on success. - -Use with care as it directly modifies the store! This is primarily meant to -be used internally by the daemon's build hook." - ;; Currently this is implemented by calling out to the fine C++ blob. - (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program - `(,@(if prefix - `("--prefix" ,prefix) - '()) - ,@(if state-directory - `("--state-directory" ,state-directory) - '()))))) - (and pipe - (begin - (format pipe "~a~%~a~%~a~%" - path (or deriver "") (length references)) - (for-each (cut format pipe "~a~%" <>) references) - (zero? (close-pipe pipe)))))) - ;;; ;;; Store monad. diff --git a/tests/store-database.scm b/tests/store-database.scm index 22c356679b..fcae66e2de 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -18,7 +18,7 @@ (define-module (test-store-database) #:use-module (guix tests) - #:use-module ((guix store) #:hide (register-path)) + #:use-module (guix store) #:use-module (guix store database) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:use-module (srfi srfi-26) diff --git a/tests/store.scm b/tests/store.scm index fdf3be33f6..afecec940a 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -777,26 +777,6 @@ (pk 'corrupt-imported imported) #f))))) -(test-assert "register-path" - (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) - "-fake"))) - (when (valid-path? %store file) - (delete-paths %store (list file))) - (false-if-exception (delete-file file)) - - (let ((ref (add-text-to-store %store "ref-of-fake" (random-text))) - (drv (string-append file ".drv"))) - (call-with-output-file file - (cut display "This is a fake store item.\n" <>)) - (register-path file - #:references (list ref) - #:deriver drv) - - (and (valid-path? %store file) - (equal? (references %store file) (list ref)) - (null? (valid-derivers %store file)) - (null? (referrers %store file)))))) - (test-assert "verify-store" (let* ((text (random-text)) (file1 (add-text-to-store %store "foo" text)) -- cgit v1.2.3 From ea0a06cee2ba05451f94714a4f913db02efbe92c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jun 2018 11:03:31 +0200 Subject: Remove 'guix-register' and its traces. * Makefile.am (SH_TESTS): Remove tests/guix-register.sh. * build-aux/pre-inst-env.in (GUIX_REGISTER): Remove. * gnu/build/install.scm (directives): Remove outdated comment. * gnu/build/vm.scm (root-partition-initializer): Update comment. * gnu/packages/package-management.scm (guix-register): Remove. * guix/config.scm.in (%sbindir, %guix-register-program): Remove. * guix/scripts/system.scm (install): Adjust docstring. * guix/self.scm (make-config.scm): Remove #:guix. Do not generate %sbindir and %guix-register-program. (specification->package): Remove "guix". * nix/guix-register/guix-register.cc: Remove. * nix/libstore/store-api.cc (decodeValidPathInfo): Remove. * nix/libstore/store-api.hh (decodeValidPathInfo): Remove declaration. * nix/local.mk (sbin_PROGRAMS, guix_register_SOURCES) (guix_register_CPPFLAGS, guix_register_LDFLAGS): Remove. * tests/guix-register.sh: Remove. --- .gitignore | 1 - Makefile.am | 7 - build-aux/pre-inst-env.in | 6 +- gnu/build/install.scm | 3 - gnu/build/vm.scm | 4 +- gnu/packages/package-management.scm | 36 ----- guix/config.scm.in | 12 +- guix/scripts/system.scm | 2 +- guix/self.scm | 21 +-- nix/guix-register/guix-register.cc | 254 ------------------------------------ nix/libstore/store-api.cc | 26 ---- nix/libstore/store-api.hh | 4 - nix/local.mk | 16 --- tests/guix-register.sh | 191 --------------------------- 14 files changed, 7 insertions(+), 576 deletions(-) delete mode 100644 nix/guix-register/guix-register.cc delete mode 100644 tests/guix-register.sh (limited to 'guix') diff --git a/.gitignore b/.gitignore index e2568ed5fe..35d50b35af 100644 --- a/.gitignore +++ b/.gitignore @@ -69,7 +69,6 @@ /etc/guix-publish.conf /etc/guix-publish.service /guix-daemon -/guix-register /guix/config.scm /libformat.a /libstore.a diff --git a/Makefile.am b/Makefile.am index f4cdba94a2..61a19b6b9e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -405,13 +405,6 @@ SH_TESTS = \ tests/guix-graph.sh \ tests/guix-lint.sh -if BUILD_DAEMON - -SH_TESTS += tests/guix-register.sh - -endif BUILD_DAEMON - - TESTS = $(SCM_TESTS) $(SH_TESTS) AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" GUILE_AUTO_COMPILE=0 diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in index 14315d40d4..286a81591c 100644 --- a/build-aux/pre-inst-env.in +++ b/build-aux/pre-inst-env.in @@ -1,7 +1,7 @@ #!/bin/sh # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2017 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès # Copyright © 2017 Eric Bavier # # This file is part of GNU Guix. @@ -55,10 +55,6 @@ NIX_BUILD_HOOK="$abs_top_builddir/nix/scripts/offload" @BUILD_DAEMON_OFFLOAD_FALSE@# No offloading support. @BUILD_DAEMON_OFFLOAD_FALSE@unset NIX_BUILD_HOOK -# The 'guix-register' program. -GUIX_REGISTER="$abs_top_builddir/guix-register" -export GUIX_REGISTER - # The following variables need only be defined when compiling Guix # modules, but we define them to be on the safe side in case of # auto-compilation. diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 06ecb39952..5a5e703872 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -110,9 +110,6 @@ STORE." ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") - - ;; XXX: 'guix-register' creates this symlink with a wrong target, so - ;; create it upfront to be sure. ("/var/guix/gcroots/profiles" -> "/var/guix/profiles") (directory "/bin") diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 803cd5996a..73d0191de7 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -346,7 +346,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." ;; Optionally, register the inputs in the image's store. (when register-closures? (unless copy-closures? - ;; XXX: 'guix-register' wants to palpate the things it registers, so + ;; XXX: 'register-closure' wants to palpate the things it registers, so ;; bind-mount the store on the target. (mkdir-p target-store) (mount (%store-directory) target-store "" MS_BIND)) @@ -365,7 +365,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (display "populating...\n") (populate-root-file-system system-directory target) - ;; 'guix-register' resets timestamps and everything, so no need to do it + ;; 'register-closure' resets timestamps and everything, so no need to do it ;; once more in that case. (unless register-closures? (reset-timestamps target)))) diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 786d2a53e9..24cf3ad015 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -294,42 +294,6 @@ the Nix package manager.") ;; Alias for backward compatibility. (define-public guix-devel guix) -(define-public guix-register - ;; This package is for internal consumption: it allows us to quickly build - ;; the 'guix-register' program, which is referred to by (guix config). - ;; TODO: Remove this hack when 'guix-register' has been superseded by Scheme - ;; code. - (package - (inherit guix) - (properties `((hidden? . #t))) - (name "guix-register") - - ;; Use a minimum set of dependencies. - (native-inputs - (fold alist-delete (package-native-inputs guix) - '("po4a" "graphviz" "help2man"))) - (propagated-inputs - `(("gnutls" ,gnutls) - ("guile-git" ,guile-git))) - - (arguments - (substitute-keyword-arguments (package-arguments guix) - ((#:tests? #f #f) - #f) - ((#:phases phases '%standard-phases) - `(modify-phases ,phases - (replace 'build - (lambda _ - (invoke "make" "nix/libstore/schema.sql.hh") - (invoke "make" "-j" (number->string - (parallel-job-count)) - "guix-register"))) - (delete 'copy-bootstrap-guile) - (replace 'install - (lambda _ - (invoke "make" "install-sbinPROGRAMS"))) - (delete 'wrap-program))))))) - (define-public guile2.0-guix (package (inherit guix) diff --git a/guix/config.scm.in b/guix/config.scm.in index aeea81bd3f..4490112e07 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès ;;; Copyright © 2017 Caleb Ristvedt ;;; ;;; This file is part of GNU Guix. @@ -26,13 +26,11 @@ %storedir %localstatedir %sysconfdir - %sbindir %store-directory %state-directory %store-database-directory %config-directory - %guix-register-program %system %libgcrypt @@ -70,9 +68,6 @@ (define %sysconfdir "@guix_sysconfdir@") -(define %sbindir - "@guix_sbindir@") - (define %store-directory (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) %storedir)) @@ -91,11 +86,6 @@ (or (getenv "GUIX_CONFIGURATION_DIRECTORY") (string-append %sysconfdir "/guix"))) -(define %guix-register-program - ;; The 'guix-register' program. - (or (getenv "GUIX_REGISTER") - (string-append %sbindir "/guix-register"))) - (define %system "@guix_system@") diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9112177bfb..727f1ac55f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -198,7 +198,7 @@ TARGET, and register them." bootcfg bootcfg-file) "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to directory TARGET. TARGET must be an absolute directory name since that's what -'guix-register' expects. +'register-path' expects. When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG." (define (maybe-copy to-copy) diff --git a/guix/self.scm b/guix/self.scm index ed3f31cdbc..3023ae379b 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -89,8 +89,6 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) - ("guix" (ref '(gnu packages package-management) - 'guix-register)) ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) @@ -565,7 +563,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the #:gzip gzip #:bzip2 bzip2 #:xz xz - #:guix guix #:package-name %guix-package-name #:package-version @@ -630,8 +627,7 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (define %dependency-variables ;; (guix config) variables corresponding to dependencies. - '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate - %sbindir %guix-register-program)) + '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate)) (define %persona-variables ;; (guix config) variables that define Guix's persona. @@ -653,7 +649,7 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (stringstring (car name+value1)) (symbol->string (car name+value2)))))) -(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 guix +(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -669,8 +665,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the %guix-version %guix-bug-report-address %guix-home-page-url - %sbindir - %guix-register-program %libgcrypt %libz %gzip @@ -688,17 +682,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (define %guix-bug-report-address #$bug-report-address) (define %guix-home-page-url #$home-page-url) - (define %sbindir - ;; This is used to define '%guix-register-program'. - ;; TODO: Use a derivation that builds nothing but the - ;; C++ part. - #+(and guix (file-append guix "/sbin"))) - - (define %guix-register-program - (or (getenv "GUIX_REGISTER") - (and %sbindir - (string-append %sbindir "/guix-register")))) - (define %gzip #+(and gzip (file-append gzip "/bin/gzip"))) (define %bzip2 diff --git a/nix/guix-register/guix-register.cc b/nix/guix-register/guix-register.cc deleted file mode 100644 index 16dae62b3d..0000000000 --- a/nix/guix-register/guix-register.cc +++ /dev/null @@ -1,254 +0,0 @@ -/* GNU Guix --- Functional package management for GNU - Copyright (C) 2013, 2014, 2015 Ludovic Courtès - Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, - 2013 Eelco Dolstra - - 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 . */ - -/* This file derives from the implementation of 'nix-store - --register-validity', by Eelco Dolstra, as found in the Nix package - manager's src/nix-store/nix-store.cc. */ - -#include - -#include -#include - -#include -#include -#include -#include - -#include -#include - -using namespace nix; - -/* Input stream where we read closure descriptions. */ -static std::istream *input = &std::cin; - - - -/* Command-line options. */ - -const char *argp_program_version = - "guix-register (" PACKAGE_NAME ") " PACKAGE_VERSION; -const char *argp_program_bug_address = PACKAGE_BUGREPORT; - -static char doc[] = -"guix-register -- register a closure as valid in a store\ -\v\ -This program is used internally when populating a store with data \ -from an existing store. It updates the new store's database with \ -information about which store files are valid, and what their \ -references are."; - -#define GUIX_OPT_STATE_DIRECTORY 1 -#define GUIX_OPT_DEDUPLICATE 2 - -static const struct argp_option options[] = - { - { "prefix", 'p', "DIRECTORY", 0, - "Open the store that lies under DIRECTORY" }, - { "state-directory", GUIX_OPT_STATE_DIRECTORY, "DIRECTORY", 0, - "Use DIRECTORY as the state directory of the target store" }, - { "no-deduplication", GUIX_OPT_DEDUPLICATE, 0, 0, - "Disable automatic deduplication of registered store items" }, - { 0, 0, 0, 0, 0 } - }; - - -/* Prefix of the store being populated. */ -static std::string prefix; - -/* Whether to deduplicate the registered store items. */ -static bool deduplication = true; - -/* Parse a single option. */ -static error_t -parse_opt (int key, char *arg, struct argp_state *state) -{ - switch (key) - { - case 'p': - { - prefix = canonPath (arg); - settings.nixStore = prefix + NIX_STORE_DIR; - settings.nixDataDir = prefix + NIX_DATA_DIR; - settings.nixLogDir = prefix + NIX_LOG_DIR; - settings.nixStateDir = prefix + NIX_STATE_DIR; - settings.nixDBPath = settings.nixStateDir + "/db"; - break; - } - - case GUIX_OPT_STATE_DIRECTORY: - { - string state_dir = canonPath (arg); - - settings.nixStateDir = state_dir; - settings.nixDBPath = state_dir + "/db"; - break; - } - - case GUIX_OPT_DEDUPLICATE: - deduplication = false; - break; - - case ARGP_KEY_ARG: - { - std::ifstream *file; - - if (state->arg_num >= 2) - /* Too many arguments. */ - argp_usage (state); - - file = new std::ifstream (); - file->open (arg); - - input = file; - } - break; - - default: - return (error_t) ARGP_ERR_UNKNOWN; - } - - return (error_t) 0; -} - -/* Argument parsing. */ -static struct argp argp = { options, parse_opt, 0, doc }; - - -/* Read from INPUT the description of a closure, and register it as valid in - STORE. The expected format on INPUT is that used by #:references-graphs: - - FILE - DERIVER - NUMBER-OF-REFERENCES - REF1 - ... - REFN - - This is really meant as an internal format. */ -static void -register_validity (LocalStore *store, std::istream &input, - bool optimize = true, - bool reregister = true, bool hashGiven = false, - bool canonicalise = true) -{ - ValidPathInfos infos; - - while (1) - { - ValidPathInfo info = decodeValidPathInfo (input, hashGiven); - if (info.path == "") - break; - - if (!prefix.empty ()) - { - /* Rewrite the input to refer to the final name, as if we were in a - chroot under PREFIX. */ - std::string final_prefix (NIX_STORE_DIR "/"); - info.path = final_prefix + baseNameOf (info.path); - } - - /* Keep its real path to canonicalize it and compute its hash. */ - std::string real_path; - real_path = prefix + "/" + settings.nixStore + "/" + baseNameOf (info.path); - - if (!store->isValidPath (info.path) || reregister) - { - /* !!! races */ - if (canonicalise) - canonicalisePathMetaData (real_path, -1); - - if (!hashGiven) - { - HashResult hash = hashPath (htSHA256, real_path); - info.hash = hash.first; - info.narSize = hash.second; - } - infos.push_back (info); - } - } - - store->registerValidPaths (infos); - - /* XXX: When PREFIX is non-empty, store->linksDir points to the original - store's '.links' directory, which means 'optimisePath' would try to link - to that instead of linking to the target store. Thus, disable - deduplication in this case. */ - if (optimize) - { - /* Make sure deduplication is enabled. */ - settings.autoOptimiseStore = true; - - std::string store_dir = settings.nixStore; - - /* 'optimisePath' creates temporary links under 'settings.nixStore' and - this must be the real target store, under PREFIX, to avoid - cross-device links. Thus, temporarily switch the value of - 'settings.nixStore'. */ - settings.nixStore = prefix + store_dir; - for (auto&& i: infos) - store->optimisePath (prefix + i.path); - settings.nixStore = store_dir; - } -} - - -int -main (int argc, char *argv[]) -{ - /* Initialize libgcrypt, which is indirectly used. */ - if (!gcry_check_version (GCRYPT_VERSION)) - { - fprintf (stderr, "error: libgcrypt version mismatch\n"); - exit (EXIT_FAILURE); - } - - /* Tell Libgcrypt that initialization has completed, as per the Libgcrypt - 1.6.0 manual (although this does not appear to be strictly needed.) */ - gcry_control (GCRYCTL_INITIALIZATION_FINISHED, 0); - - /* Honor the environment variables, and initialize the settings. */ - settings.processEnvironment (); - - try - { - argp_parse (&argp, argc, argv, 0, 0, 0); - - /* Instantiate the store. This creates any missing directories among - 'settings.nixStore', 'settings.nixDBPath', etc. */ - LocalStore store; - - if (!prefix.empty ()) - /* Under the --prefix tree, the final name of the store will be - NIX_STORE_DIR. Set it here so that the database uses file names - prefixed by NIX_STORE_DIR and not PREFIX + NIX_STORE_DIR. */ - settings.nixStore = NIX_STORE_DIR; - - register_validity (&store, *input, deduplication); - } - catch (std::exception &e) - { - fprintf (stderr, "error: %s\n", e.what ()); - return EXIT_FAILURE; - } - - return EXIT_SUCCESS; -} diff --git a/nix/libstore/store-api.cc b/nix/libstore/store-api.cc index 6742d2ed49..9e07c67e97 100644 --- a/nix/libstore/store-api.cc +++ b/nix/libstore/store-api.cc @@ -226,32 +226,6 @@ string StoreAPI::makeValidityRegistration(const PathSet & paths, return s; } - -ValidPathInfo decodeValidPathInfo(std::istream & str, bool hashGiven) -{ - ValidPathInfo info; - getline(str, info.path); - if (str.eof()) { info.path = ""; return info; } - if (hashGiven) { - string s; - getline(str, s); - info.hash = parseHash(htSHA256, s); - getline(str, s); - if (!string2Int(s, info.narSize)) throw Error("number expected"); - } - getline(str, info.deriver); - string s; int n; - getline(str, s); - if (!string2Int(s, n)) throw Error("number expected"); - while (n--) { - getline(str, s); - info.references.insert(s); - } - if (!str || str.eof()) throw Error("missing input"); - return info; -} - - string showPaths(const PathSet & paths) { string s; diff --git a/nix/libstore/store-api.hh b/nix/libstore/store-api.hh index e957cedebc..2d9dcbd573 100644 --- a/nix/libstore/store-api.hh +++ b/nix/libstore/store-api.hh @@ -371,10 +371,6 @@ std::shared_ptr openStore(bool reserveSpace = true); string showPaths(const PathSet & paths); -ValidPathInfo decodeValidPathInfo(std::istream & str, - bool hashGiven = false); - - /* Export multiple paths in the format expected by ‘nix-store --import’. */ void exportPaths(StoreAPI & store, const Paths & paths, diff --git a/nix/local.mk b/nix/local.mk index b4c6ba61a4..140c78df37 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -120,7 +120,6 @@ libstore_a_CXXFLAGS = $(AM_CXXFLAGS) \ $(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS) bin_PROGRAMS = guix-daemon -sbin_PROGRAMS = guix-register guix_daemon_SOURCES = \ %D%/nix-daemon/nix-daemon.cc \ @@ -138,24 +137,9 @@ guix_daemon_LDADD = \ guix_daemon_headers = \ %D%/nix-daemon/shared.hh - -guix_register_SOURCES = \ - %D%/guix-register/guix-register.cc - -guix_register_CPPFLAGS = \ - $(libutil_a_CPPFLAGS) \ - $(libstore_a_CPPFLAGS) \ - -I$(top_srcdir)/%D%/libstore - -# XXX: Should we start using shared libs? -guix_register_LDADD = \ - libstore.a libutil.a libformat.a -lz \ - $(SQLITE3_LIBS) $(LIBGCRYPT_LIBS) - if HAVE_LIBBZ2 guix_daemon_LDADD += -lbz2 -guix_register_LDADD += -lbz2 endif HAVE_LIBBZ2 diff --git a/tests/guix-register.sh b/tests/guix-register.sh deleted file mode 100644 index 521735b8a4..0000000000 --- a/tests/guix-register.sh +++ /dev/null @@ -1,191 +0,0 @@ -# GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès -# -# 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 . - -# -# Test the 'guix-register' command-line utility. -# - -guix-register --version - -new_store="t-register-$$" -closure="t-register-closure-$$" -rm -rf "$new_store" - -exit_hook=":" -trap "chmod -R +w $new_store ; rm -rf $new_store $closure ; \$exit_hook" EXIT - -# -# Registering items in the current store---i.e., without '--prefix'. -# - -new_file="$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-guix-register-$$" -echo "Fake store file to test registration." > "$new_file" - -# Register the file with zero references and no deriver. -guix-register < "$new_file2" -guix-register <> "$closure" < Date: Thu, 14 Jun 2018 21:17:08 +0200 Subject: guix: ui: Allow translation of dates. * guix/ui.scm (display-generation): Allow translation of dates. The format string will show dates as month day year, but some languages use a different convention. --- guix/ui.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 99f66b0fdc..31830ee850 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1391,7 +1391,12 @@ DURATION-RELATION with the current time." (date->string (time-utc->date (generation-time profile number)) - "~b ~d ~Y ~T"))) + ;; TRANSLATORS: This is a format-string for date->string. + ;; Please choose a format that corresponds to the + ;; usual way of presenting dates in your locale. + ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html + ;; for details. + (G_ "~b ~d ~Y ~T")))) (current (generation-number profile))) (if (= number current) ;; TRANSLATORS: The word "current" here is an adjective for -- cgit v1.2.3 From baed923682802b7281bd68274f080d2bb55d3eff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Jun 2018 21:59:23 +0200 Subject: self: Add 'guix-daemon' to the result. * gnu/packages/package-management.scm (guix-daemon): New variable. * guix/self.scm (whole-package): Add #:daemon and honor it. (compiled-guix): Pass #:daemon to 'whole-package'. --- gnu/packages/package-management.scm | 47 +++++++++++++++++++++++++++++++++++++ guix/self.scm | 15 +++++++++++- 2 files changed, 61 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 24cf3ad015..6d99cddc0d 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -294,6 +294,53 @@ the Nix package manager.") ;; Alias for backward compatibility. (define-public guix-devel guix) +(define-public guix-daemon + ;; This package is for internal consumption: it allows us to quickly build + ;; the 'guix-daemon' program and use that in (guix self), used by 'guix + ;; pull'. + (package + (inherit guix) + (properties `((hidden? . #t))) + (name "guix-daemon") + + ;; Use a minimum set of dependencies. + (native-inputs + (fold alist-delete (package-native-inputs guix) + '("po4a" "graphviz" "help2man"))) + (inputs + `(("gnutls" ,gnutls) + ("guile-git" ,guile-git) + ,@(package-inputs guix))) + (propagated-inputs '()) + + (arguments + (substitute-keyword-arguments (package-arguments guix) + ((#:tests? #f #f) + #f) + ((#:phases phases '%standard-phases) + `(modify-phases ,phases + (replace 'build + (lambda _ + (invoke "make" "nix/libstore/schema.sql.hh") + (invoke "make" "-j" (number->string + (parallel-job-count)) + "guix-daemon"))) + (delete 'copy-bootstrap-guile) + (replace 'install + (lambda* (#:key outputs #:allow-other-keys) + (invoke "make" "install-binPROGRAMS" + "install-nodist_pkglibexecSCRIPTS") + + ;; We need to tell 'guix-daemon' which 'guix' command to use. + ;; Here we use a questionable hack where we hard-code + ;; "~root/.config", which could be wrong (XXX). + (let ((out (assoc-ref outputs "out"))) + (substitute* (find-files (string-append out "/libexec")) + (("exec \".*/bin/guix\"") + "exec ~root/.config/current/bin/guix")) + #t))) + (delete 'wrap-program))))))) + (define-public guile2.0-guix (package (inherit guix) diff --git a/guix/self.scm b/guix/self.scm index 3023ae379b..1306df46f5 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -385,7 +385,7 @@ load path." (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) - info + info daemon (command (guix-command modules #:dependencies dependencies #:guile-version guile-version))) @@ -401,6 +401,10 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (symlink #$command (string-append #$output "/bin/guix")) + (when #$daemon + (symlink (string-append #$daemon "/bin/guix-daemon") + (string-append #$output "/bin/guix-daemon"))) + (let ((modules (string-append #$output "/share/guile/site/" (effective-version))) @@ -611,6 +615,15 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the #:guile-version guile-version))) (whole-package name built-modules dependencies #:command command + + ;; Include 'guix-daemon'. XXX: Here we inject an + ;; older snapshot of guix-daemon, but that's a good + ;; enough approximation for now. + #:daemon (module-ref (resolve-interface + '(gnu packages + package-management)) + 'guix-daemon) + #:info (info-manual source) #:guile-version guile-version))) ((= 0 pull-version) -- cgit v1.2.3 From a9a685cc0024a4e0dad5d7abd9ca6fb880ae4f8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Jun 2018 23:08:08 +0200 Subject: offload: Gracefully handle invalid results from 'machines.scm'. * guix/scripts/offload.scm (build-machines): Check the result of FILE. Ignore it if it's not a list of . --- guix/scripts/offload.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index fb61d7c059..664497bcd5 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -124,7 +124,15 @@ determined." (save-module-excursion (lambda () (set-current-module %user-module) - (primitive-load file)))) + (match (primitive-load file) + (((? build-machine? machines) ...) + machines) + (_ + ;; Instead of crashing, assume the empty list. + (warning (G_ "'~a' did not return a list of build machines; \ +ignoring it~%") + file) + '()))))) (lambda args (match args (('system-error . rest) -- cgit v1.2.3 From 265048cc897af8189c64cdfaa41820490f8fad9e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 Jun 2018 09:02:01 +0200 Subject: offload: Fix error message in 'guix offload test'. Reported by Maxim Cournoyer in . * guix/scripts/offload.scm (assert-node-has-guix): Fix typo in failure message; add missing argument. --- guix/scripts/offload.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 664497bcd5..ee5857e16b 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -613,8 +613,8 @@ If TIMEOUT is #f, simply evaluate EXP..." (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") name x)))) (lambda (key . args) - (leave (G_ "remove evaluation on '~a' failed:~{ ~s~}~%") - args)))) + (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%") + name args)))) (define %random-state (delay -- cgit v1.2.3 From 259341cf93de80533d212cb73e5e652aa4bc716c Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Tue, 12 Jun 2018 19:51:23 +0200 Subject: gnu: ldb: Fix build on 32-bit systems. * guix/utils.scm (target-64bit?): New procedure. * gnu/packages/samba.scm (ldb)[inputs]: Only add LMDB on 64-bit systems. [arguments]: Make #:tests? conditional on LMDB availability. --- gnu/packages/samba.scm | 9 +++++++-- guix/utils.scm | 6 ++++++ 2 files changed, 13 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/gnu/packages/samba.scm b/gnu/packages/samba.scm index abbfdd83c4..e10f00a83b 100644 --- a/gnu/packages/samba.scm +++ b/gnu/packages/samba.scm @@ -362,7 +362,10 @@ many event types, including timers, signals, and the classic file descriptor eve #t)))) (build-system gnu-build-system) (arguments - '(#:phases + '(;; LMDB is only supported on 64-bit systems, yet the test suite + ;; requires it. + #:tests? (assoc-ref %build-inputs "lmdb") + #:phases (modify-phases %standard-phases (replace 'configure ;; ldb use a custom configuration script that runs waf. @@ -382,7 +385,9 @@ many event types, including timers, signals, and the classic file descriptor eve `(("talloc" ,talloc) ("tdb" ,tdb))) (inputs - `(("lmdb" ,lmdb) + `(,@(if (target-64bit?) + `(("lmdb" ,lmdb)) + '()) ("popt" ,popt) ("tevent" ,tevent))) (synopsis "LDAP-like embedded database") diff --git a/guix/utils.scm b/guix/utils.scm index e9efea5866..a5de9605e7 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2015 David Thompson ;;; Copyright © 2017 Efraim Flashner ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; @@ -77,6 +78,7 @@ package-name->name+version target-mingw? target-arm32? + target-64bit? version-compare version>? version>=? @@ -474,6 +476,10 @@ a character other than '@'." (define (target-arm32?) (string-prefix? "arm" (or (%current-target-system) (%current-system)))) +(define (target-64bit?) + (let ((system (or (%current-target-system) (%current-system)))) + (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64")))) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) -- cgit v1.2.3 From a89faa3faac96436cfb2d7052307c58dc2bb4ad6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Jun 2018 01:35:54 +0200 Subject: self: Install .go files to 'lib/guile/X.Y/site-ccache'. * guix/self.scm (guix-command): Add 'compiled-modules' parameter and honor it. (whole-package): Likewise. (compiled-guix)[built-modules]: Turn into a procedure. When PULL-VERSION is 1, use separate source and compiled modules. When PULL-VERSION is 0, return a single directory containing both .scm and .go files. --- guix/self.scm | 48 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 1306df46f5..5a10f72012 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -340,7 +340,8 @@ DOMAIN, a gettext domain." (computed-file "guix-manual" build)) -(define* (guix-command modules #:key source (dependencies '()) +(define* (guix-command modules #:optional compiled-modules + #:key source (dependencies '()) (guile-version (effective-version))) "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its load path." @@ -364,7 +365,8 @@ load path." (set! %load-path (cons #$modules %load-path)) (set! %load-compiled-path - (cons #$modules %load-compiled-path)) + (cons (or #$compiled-modules #$modules) + %load-compiled-path)) (let ((guix-main (module-ref (resolve-interface '(guix ui)) 'guix-main))) @@ -385,14 +387,16 @@ load path." (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) + compiled-modules info daemon (command (guix-command modules #:dependencies dependencies #:guile-version guile-version))) "Return the whole Guix package NAME that uses MODULES, a derivation of all the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the -'guix' program to use; INFO is the Info manual." - ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'. +'guix' program to use; INFO is the Info manual. When COMPILED-MODULES is +true, it is linked as 'lib/guile/X.Y/site-ccache'; otherwise, .go files are +assumed to be part of MODULES." (computed-file name (with-imported-modules '((guix build utils)) #~(begin @@ -414,7 +418,15 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (when info (symlink #$info (string-append #$output - "/share/info")))))))) + "/share/info")))) + + ;; Object files. + (when #$compiled-modules + (let ((modules (string-append #$output "/lib/guile/" + (effective-version) + "/site-ccache"))) + (mkdir-p (dirname modules)) + (symlink #$compiled-modules modules))))))) (define* (compiled-guix source #:key (version %guix-version) (pull-version 1) @@ -577,11 +589,9 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the %guix-home-page-url))) #:guile-for-build guile-for-build)) - (define built-modules + (define (built-modules node-subset) (directory-union (string-append name "-modules") - (append-map (lambda (node) - (list (node-source node) - (node-compiled node))) + (append-map node-subset ;; Note: *CONFIG* comes first so that it ;; overrides the (guix config) module that @@ -609,11 +619,14 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the ;; Version 1 is when we return the full package. (cond ((= 1 pull-version) ;; The whole package, with a standard file hierarchy. - (let ((command (guix-command built-modules - #:source source - #:dependencies dependencies - #:guile-version guile-version))) - (whole-package name built-modules dependencies + (let* ((modules (built-modules (compose list node-source))) + (compiled (built-modules (compose list node-compiled))) + (command (guix-command modules compiled + #:source source + #:dependencies dependencies + #:guile-version guile-version))) + (whole-package name modules dependencies + #:compiled-modules compiled #:command command ;; Include 'guix-daemon'. XXX: Here we inject an @@ -627,8 +640,11 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the #:info (info-manual source) #:guile-version guile-version))) ((= 0 pull-version) - ;; Legacy 'guix pull': just return the compiled modules. - built-modules) + ;; Legacy 'guix pull': return the .scm and .go files as one + ;; directory. + (built-modules (lambda (node) + (list (node-source node) + (node-compiled node))))) (else ;; Unsupported 'guix pull' version. #f))) -- cgit v1.2.3 From 32eb44240db23b2320a68a3ab17370531945587f Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 18 Jun 2018 13:50:33 +0200 Subject: build-system/r: Accept #:r argument. * guix/build-system/r.scm (lower): Add #:r to private-keywords. --- guix/build-system/r.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index d20f66e1a9..d5f897932f 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ricardo Wurmus +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,7 +74,7 @@ release corresponding to NAME and VERSION." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:inputs #:native-inputs)) + '(#:source #:target #:r #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag -- cgit v1.2.3