From 01445711db6771cea6122859c3f717f130359f55 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 7 Jan 2017 00:48:11 +0100 Subject: guix archive: '-f docker' supports package names as arguments. This allows users to type: guix archive -f docker emacs as was already the case for the 'nar' format. Reported by David Thompson. * guix/scripts/archive.scm (%default-options): Add 'format'. (export-from-store): Dispatch based on the 'format' key in OPTS. (guix-archive): Call 'export-from-store' in all cases when the 'export' key is in OPTS. --- guix/scripts/archive.scm | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 6eba9e000..3e056fda9 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -53,7 +53,8 @@ (define %default-options ;; Alist of default option values. - `((system . ,(%current-system)) + `((format . "nar") + (system . ,(%current-system)) (substitutes? . #t) (graft? . #t) (max-silent-time . 3600) @@ -253,8 +254,21 @@ resulting archive to the standard output port." (if (or (assoc-ref opts 'dry-run?) (build-derivations store drv)) - (export-paths store files (current-output-port) - #:recursive? (assoc-ref opts 'export-recursive?)) + (match (assoc-ref opts 'format) + ("nar" + (export-paths store files (current-output-port) + #:recursive? (assoc-ref opts 'export-recursive?))) + ("docker" + (match files + ((file) + (let ((system (assoc-ref opts 'system))) + (format #t "~a\n" + (build-docker-image file #:system system)))) + (_ + ;; TODO: Remove this restriction. + (leave (_ "only a single item can be exported to Docker~%"))))) + (format + (leave (_ "~a: unknown archive format~%") format))) (leave (_ "unable to export the given packages~%"))))) (define (generate-key-pair parameters) @@ -338,15 +352,7 @@ the input port." (else (with-store store (cond ((assoc-ref opts 'export) - (cond ((equal? (assoc-ref opts 'format) "docker") - (match (car opts) - (('argument . (? store-path? item)) - (format #t "~a\n" - (build-docker-image - item - #:system (assoc-ref opts 'system)))) - (_ (leave (_ "argument must be a direct store path~%"))))) - (_ (export-from-store store opts)))) + (export-from-store store opts)) ((assoc-ref opts 'import) (import-paths store (current-input-port))) ((assoc-ref opts 'missing) -- cgit v1.3 From 1545a012cb7cd78e25ed99ecee26df457be590e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Jan 2017 15:55:57 +0100 Subject: guix archive: Allow compilation in the absence of Guile-JSON. Fixes . Reported by Ben Woodcroft . * guix/scripts/archive.scm: Use 'module-autoload!' instead of #:use-module to (guix docker). --- guix/scripts/archive.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 3e056fda9..9e49c5363 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -31,7 +31,6 @@ #:use-module (guix ui) #:use-module (guix pki) #:use-module (guix pk-crypto) - #:use-module (guix docker) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) @@ -46,6 +45,11 @@ #:export (guix-archive options->derivations+files)) +;; XXX: Use this hack instead of #:autoload to avoid compilation errors. +;; See . +(module-autoload! (current-module) + '(guix docker) '(build-docker-image)) + ;;; ;;; Command-line options. -- cgit v1.3 From aa042770da2fe6411089a965ea8b2219a99d3448 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Jan 2017 11:55:51 +0100 Subject: guix package: Fix version and output for 'guix package -i /gnu/store/…'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (package-name->name+version): Add optional 'delimiter' parameter. * guix/scripts/package.scm (store-item->manifest-entry): Pass #\- as the delimiter for 'package-name->name+version'. Use "out" instead of #f for the 'output' field. * tests/guix-package.sh: Add test. --- guix/scripts/package.scm | 7 ++++--- guix/utils.scm | 10 ++++++---- tests/guix-package.sh | 10 +++++++++- 3 files changed, 19 insertions(+), 8 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 90e7fa229..9e5b7f3c7 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.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, 2017 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2013, 2015 Mark H Weaver ;;; Copyright © 2014, 2016 Alex Kost @@ -577,11 +577,12 @@ upgrading, #f otherwise." (define (store-item->manifest-entry item) "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name." (let-values (((name version) - (package-name->name+version (store-path-package-name item)))) + (package-name->name+version (store-path-package-name item) + #\-))) (manifest-entry (name name) (version version) - (output #f) + (output "out") ;XXX: wild guess (item item)))) (define (options->installable opts manifest transaction) diff --git a/guix/utils.scm b/guix/utils.scm index 06f49daca..ee06e47fe 100644 --- a/guix/utils.scm +++ b/guix/utils.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, 2017 Ludovic Courtès ;;; Copyright © 2013, 2014, 2015 Mark H Weaver ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2014 Ian Denhardt @@ -500,11 +500,13 @@ returned by `config.guess'." ;; cross-building to. (make-parameter #f)) -(define (package-name->name+version spec) +(define* (package-name->name+version spec + #:optional (delimiter #\@)) "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\" and \"0.9.1b\". When the version part is unavailable, SPEC and #f are -returned. Both parts must not contain any '@'." - (match (string-rindex spec #\@) +returned. Both parts must not contain any '@'. Optionally, DELIMITER can be +a character other than '@'." + (match (string-rindex spec delimiter) (#f (values spec #f)) (idx (values (substring spec 0 idx) (substring spec (1+ idx)))))) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 68a1946aa..5ecb33193 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -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, 2017 Ludovic Courtès # Copyright © 2013 Nikita Karetnikov # # This file is part of GNU Guix. @@ -39,6 +39,14 @@ trap 'rm -f "$profile" "$profile-"[0-9]* "$tmpfile"; rm -rf "$module_dir" t-home if guix package --bootstrap -e +; then false; else true; fi +# Install a store item and make sure the version and output in the manifest +# are correct. +guix package --bootstrap -p "$profile" -i `guix build guile-bootstrap` +test "`guix package -A guile-bootstrap | cut -f 1-2`" \ + = "`guix package -p "$profile" -I | cut -f 1-2`" +test "`guix package -p "$profile" -I | cut -f 3`" = "out" +rm "$profile" + guix package --bootstrap -p "$profile" -i guile-bootstrap test -L "$profile" && test -L "$profile-1-link" test -f "$profile/bin/guile" -- cgit v1.3 From 9b5364a3afb03414bd6e3ded2fbfdacabe4e8870 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Jan 2017 17:06:31 +0100 Subject: daemon: Allow check builds of 'builtin:download' derivations. Fixes . Reported by Leo Famulari . * nix/libstore/build.cc (DerivationGoal::runChild): In the 'isBuiltin' case, check whether DRV's output is in 'redirectedOutputs', and pass an 'output' argument to the built-in builder. (DerivationGoal::addHashRewrite): Add 'printMsg' call. * nix/libstore/builtins.hh (derivationBuilder): Add 'output' parameter. * nix/libstore/builtins.cc (builtinDownload): Likewise. Add OUTPUT to ARGV. * guix/scripts/perform-download.scm (perform-download): Add 'output' parameter. (guix-perform-download): Adjust 'match' clauses accordingly. * tests/derivations.scm ("'download' built-in builder, check mode"): New test. --- guix/scripts/perform-download.scm | 21 +++++++++++++-------- nix/libstore/build.cc | 15 +++++++++++++-- nix/libstore/builtins.cc | 10 +++++++--- nix/libstore/builtins.hh | 5 +++-- tests/derivations.scm | 27 ++++++++++++++++++++++++++- 5 files changed, 62 insertions(+), 16 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 0d2e7089a..58a737714 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +19,7 @@ (define-module (guix scripts perform-download) #:use-module (guix ui) #:use-module (guix derivations) - #:use-module ((guix store) #:select (derivation-path?)) + #:use-module ((guix store) #:select (derivation-path? store-path?)) #:use-module (guix build download) #:use-module (ice-9 match) #:export (guix-perform-download)) @@ -41,10 +41,13 @@ (module-use! module (resolve-interface '(guix base32))) module)) -(define (perform-download drv) - "Perform the download described by DRV, a fixed-output derivation." +(define (perform-download drv output) + "Perform the download described by DRV, a fixed-output derivation, to +OUTPUT. + +Note: We don't read the value of 'out' in DRV since the actual output is +different from that when we're doing a 'bmCheck' or 'bmRepair' build." (derivation-let drv ((url "url") - (output "out") (executable "executable") (mirrors "mirrors") (content-addressed-mirrors "content-addressed-mirrors")) @@ -93,18 +96,20 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See ." (with-error-handling (match args - (((? derivation-path? drv)) + (((? derivation-path? drv) (? store-path? output)) ;; This program must be invoked by guix-daemon under an unprivileged ;; UID to prevent things downloading from 'file:///etc/shadow' or ;; arbitrary code execution via the content-addressed mirror ;; procedures. (That means we exclude users who did not pass ;; '--build-users-group'.) (assert-low-privileges) - (perform-download (call-with-input-file drv read-derivation))) + (perform-download (call-with-input-file drv read-derivation) + output)) (("--version") (show-version-and-exit)) (x - (leave (_ "fixed-output derivation name expected~%")))))) + (leave + (_ "fixed-output derivation and output file name expected~%")))))) ;; Local Variables: ;; eval: (put 'derivation-let 'scheme-indent-function 2) diff --git a/nix/libstore/build.cc b/nix/libstore/build.cc index 38048ceeb..cebc404d1 100644 --- a/nix/libstore/build.cc +++ b/nix/libstore/build.cc @@ -2271,8 +2271,17 @@ void DerivationGoal::runChild() logType = ltFlat; auto buildDrv = lookupBuiltinBuilder(drv.builder); - if (buildDrv != NULL) - buildDrv(drv, drvPath); + if (buildDrv != NULL) { + /* Check what the output file name is. When doing a + 'bmCheck' build, the output file name is different from + that specified in DRV due to hash rewriting. */ + Path output = drv.outputs["out"].path; + auto redirected = redirectedOutputs.find(output); + if (redirected != redirectedOutputs.end()) + output = redirected->second; + + buildDrv(drv, drvPath, output); + } else throw Error(format("unsupported builtin function '%1%'") % string(drv.builder, 8)); _exit(0); @@ -2742,6 +2751,8 @@ Path DerivationGoal::addHashRewrite(const Path & path) rewritesToTmp[h1] = h2; rewritesFromTmp[h2] = h1; redirectedOutputs[path] = p; + printMsg(lvlChatty, format("output '%1%' redirected to '%2%'") + % path % p); return p; } diff --git a/nix/libstore/builtins.cc b/nix/libstore/builtins.cc index 32af767dc..7ed75e507 100644 --- a/nix/libstore/builtins.cc +++ b/nix/libstore/builtins.cc @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2016 Ludovic Courtès + Copyright (C) 2016, 2017 Ludovic Courtès This file is part of GNU Guix. @@ -25,7 +25,8 @@ namespace nix { static void builtinDownload(const Derivation &drv, - const std::string &drvPath) + const std::string &drvPath, + const std::string &output) { /* Invoke 'guix perform-download'. */ Strings args; @@ -35,7 +36,10 @@ static void builtinDownload(const Derivation &drv, /* Close all other file descriptors. */ closeMostFDs(set()); - const char *const argv[] = { "download", drvPath.c_str(), NULL }; + const char *const argv[] = + { + "download", drvPath.c_str(), output.c_str(), NULL + }; /* XXX: Hack our way to use the 'download' script from 'LIBEXECDIR/guix' or just 'LIBEXECDIR', depending on whether we're running uninstalled or diff --git a/nix/libstore/builtins.hh b/nix/libstore/builtins.hh index 79171fcb6..396ea14eb 100644 --- a/nix/libstore/builtins.hh +++ b/nix/libstore/builtins.hh @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2016 Ludovic Courtès + Copyright (C) 2016, 2017 Ludovic Courtès This file is part of GNU Guix. @@ -33,7 +33,8 @@ namespace nix { /* Build DRV, which lives at DRVPATH. */ typedef void (*derivationBuilder) (const Derivation &drv, - const std::string &drvPath); + const std::string &drvPath, + const std::string &output); /* Return the built-in builder called BUILDER, or NULL if none was found. */ diff --git a/tests/derivations.scm b/tests/derivations.scm index 2b5aa796d..3fbfec379 100644 --- a/tests/derivations.scm +++ b/tests/derivations.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, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -279,6 +279,27 @@ (build-derivations %store (list drv)) #f))) +(unless (force %http-server-socket) + (test-skip 1)) +(test-assert "'download' built-in builder, check mode" + ;; Make sure rebuilding the 'builtin:download' derivation in check mode + ;; works. See . + (let* ((text (random-text)) + (drv (derivation %store "world" + "builtin:download" '() + #:env-vars `(("url" + . ,(object->string (%local-url)))) + #:hash-algo 'sha256 + #:hash (sha256 (string->utf8 text))))) + (and (with-http-server 200 text + (build-derivations %store (list drv))) + (with-http-server 200 text + (build-derivations %store (list drv) + (build-mode check))) + (string=? (call-with-input-file (derivation->output-path drv) + get-string-all) + text)))) + (test-equal "derivation-name" "foo-0.0" (let ((drv (derivation %store "foo-0.0" %bash '()))) @@ -1109,3 +1130,7 @@ (call-with-input-file out get-string-all)))) (test-end) + +;; Local Variables: +;; eval: (put 'with-http-server 'scheme-indent-function 2) +;; End: -- cgit v1.3 From 26ab00a0a9c79f85641a305fb13e36476b9a0427 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Jan 2017 22:40:00 +0100 Subject: perform-download: Add backward-compatible case. This is meant to ease transition for people running an older guix-daemon invoking a recent 'guix perform-download' with only one argument. This is a followup to 9b5364a3afb03414bd6e3ded2fbfdacabe4e8870. * guix/scripts/perform-download.scm (perform-download): Make 'output' optional. Bind 'output*' from DRV's "out" and honor it. (guix-perform-download): Add clause with one argument. --- guix/scripts/perform-download.scm | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 58a737714..59ade0a8c 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -41,20 +41,23 @@ (module-use! module (resolve-interface '(guix base32))) module)) -(define (perform-download drv output) +(define* (perform-download drv #:optional output) "Perform the download described by DRV, a fixed-output derivation, to OUTPUT. -Note: We don't read the value of 'out' in DRV since the actual output is -different from that when we're doing a 'bmCheck' or 'bmRepair' build." +Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the +actual output is different from that when we're doing a 'bmCheck' or +'bmRepair' build." (derivation-let drv ((url "url") + (output* "out") (executable "executable") (mirrors "mirrors") (content-addressed-mirrors "content-addressed-mirrors")) (unless url (leave (_ "~a: missing URL~%") (derivation-file-name drv))) - (let* ((url (call-with-input-string url read)) + (let* ((output (or output output*)) + (url (call-with-input-string url read)) (drv-output (assoc-ref (derivation-outputs drv) "out")) (algo (derivation-output-hash-algo drv-output)) (hash (derivation-output-hash drv-output))) @@ -94,17 +97,20 @@ the daemon and not explicitly described as an input of the derivation. This allows us to sidestep bootstrapping problems, such downloading the source code of GnuTLS over HTTPS, before we have built GnuTLS. See ." + + ;; This program must be invoked by guix-daemon under an unprivileged UID to + ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code + ;; execution via the content-addressed mirror procedures. (That means we + ;; exclude users who did not pass '--build-users-group'.) (with-error-handling (match args (((? derivation-path? drv) (? store-path? output)) - ;; This program must be invoked by guix-daemon under an unprivileged - ;; UID to prevent things downloading from 'file:///etc/shadow' or - ;; arbitrary code execution via the content-addressed mirror - ;; procedures. (That means we exclude users who did not pass - ;; '--build-users-group'.) (assert-low-privileges) (perform-download (call-with-input-file drv read-derivation) output)) + (((? derivation-path? drv)) ;backward compatibility + (assert-low-privileges) + (perform-download (call-with-input-file drv read-derivation))) (("--version") (show-version-and-exit)) (x -- cgit v1.3 From 4cdff6ae37878588a550e5969381d531c728e2fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Jan 2017 23:14:58 +0100 Subject: challenge: Use a warning when substitutes are lacking. * guix/scripts/challenge.scm (discrepancies): Use 'warning' instead of 'leave'. --- guix/scripts/challenge.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 590d8f109..9ab4fbe2a 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -118,7 +118,7 @@ taken since we do not import the archives." (select-reference item narinfos urls) (narinfo-hash->sha256 (narinfo-hash first)))))) (() - (leave (_ "no substitutes for '~a'~%") item)))) + (warning (_ "no substitutes for '~a'; cannot conclude~%") item)))) (mlet* %store-monad ((local (mapm %store-monad query-locally-built-hash items)) -- cgit v1.3 From 4d8e95097e5c40da9dd57d358bd189dcf82ff9bf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 23:30:43 +0100 Subject: challenge: Return comparison reports instead of just discrepancies. This makes it easier to distinguish between matches, mismatches, and the various cases of inconclusive reports. * guix/scripts/challenge.scm (): Rename to... (): ... this. Add 'result' field. (comparison-report): New macro. (comparison-report-predicate, comparison-report-mismatch?) (comparison-report-match?) (comparison-report-inconclusive?): New procedures. (discrepancies): Rename to... (compare-contents): ... this. Change to return a list of . Remove calls to 'warning'. (summarize-discrepancy): Rename to... (summarize-report): ... this. Adjust to . (guix-challenge): Likewise. * tests/challenge.scm ("no discrepancies") ("one discrepancy"): Adjust to new API. ("inconclusive: no substitutes") ("inconclusive: no local build"): New tests. --- guix/scripts/challenge.scm | 161 ++++++++++++++++++++++++++++----------------- tests/challenge.scm | 62 ++++++++++++++--- 2 files changed, 152 insertions(+), 71 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 9ab4fbe2a..f14e931d7 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,12 +37,17 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:use-module (web uri) - #:export (discrepancies + #:export (compare-contents - discrepancy? - discrepancy-item - discrepancy-local-sha256 - discrepancy-narinfos + comparison-report? + comparison-report-item + comparison-report-result + comparison-report-local-sha256 + comparison-report-narinfos + + comparison-report-match? + comparison-report-mismatch? + comparison-report-inconclusive? guix-challenge)) @@ -61,13 +66,38 @@ (define ensure-store-item ;XXX: move to (guix ui)? (@@ (guix scripts size) ensure-store-item)) -;; Representation of a hash mismatch for ITEM. -(define-record-type - (discrepancy item local-sha256 narinfos) - discrepancy? - (item discrepancy-item) ;string, /gnu/store/… item - (local-sha256 discrepancy-local-sha256) ;bytevector | #f - (narinfos discrepancy-narinfos)) ;list of +;; Representation of a comparison report for ITEM. +(define-record-type + (%comparison-report item result local-sha256 narinfos) + comparison-report? + (item comparison-report-item) ;string, /gnu/store/… item + (result comparison-report-result) ;'match | 'mismatch | 'inconclusive + (local-sha256 comparison-report-local-sha256) ;bytevector | #f + (narinfos comparison-report-narinfos)) ;list of + +(define-syntax comparison-report + ;; Some sort of a an enum to make sure 'result' is correct. + (syntax-rules (match mismatch inconclusive) + ((_ item 'match rest ...) + (%comparison-report item 'match rest ...)) + ((_ item 'mismatch rest ...) + (%comparison-report item 'mismatch rest ...)) + ((_ item 'inconclusive rest ...) + (%comparison-report item 'inconclusive rest ...)))) + +(define (comparison-report-predicate result) + "Return a predicate that returns true when pass a REPORT that has RESULT." + (lambda (report) + (eq? (comparison-report-result report) result))) + +(define comparison-report-mismatch? + (comparison-report-predicate 'mismatch)) + +(define comparison-report-match? + (comparison-report-predicate 'match)) + +(define comparison-report-inconclusive? + (comparison-report-predicate 'inconclusive)) (define (locally-built? store item) "Return true if ITEM was built locally." @@ -88,10 +118,10 @@ Otherwise return #f." (define-syntax-rule (report args ...) (format (current-error-port) args ...)) -(define (discrepancies items servers) +(define (compare-contents items servers) "Challenge the substitute servers whose URLs are listed in SERVERS by comparing the hash of the substitutes of ITEMS that they serve. Return the -list of discrepancies. +list of objects. This procedure does not authenticate narinfos from SERVERS, nor does it verify that they are signed by an authorized public keys. The reason is that, by @@ -100,11 +130,7 @@ taken since we do not import the archives." (define (compare item reference) ;; Return a procedure to compare the hash of ITEM with REFERENCE. (lambda (narinfo url) - (if (not narinfo) - (begin - (warning (_ "~a: no substitute at '~a'~%") - item url) - #t) + (or (not narinfo) (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo)))) (bytevector=? reference value))))) @@ -116,9 +142,7 @@ taken since we do not import the archives." ((url urls ...) (if (not first) (select-reference item narinfos urls) - (narinfo-hash->sha256 (narinfo-hash first)))))) - (() - (warning (_ "no substitutes for '~a'; cannot conclude~%") item)))) + (narinfo-hash->sha256 (narinfo-hash first)))))))) (mlet* %store-monad ((local (mapm %store-monad query-locally-built-hash items)) @@ -130,42 +154,54 @@ taken since we do not import the archives." vhash)) vlist-null remote))) - (return (filter-map (lambda (item local) - (let ((narinfos (vhash-fold* cons '() item narinfos))) - (define reference - (or local - (begin - (warning (_ "no local build for '~a'~%") item) - (select-reference item narinfos servers)))) - - (if (every (compare item reference) - narinfos servers) - #f - (discrepancy item local narinfos)))) - items - local)))) - -(define* (summarize-discrepancy discrepancy - #:key (hash->string - bytevector->nix-base32-string)) - "Write to the current error port a summary of DISCREPANCY, a -object that denotes a hash mismatch." - (match discrepancy - (($ item local (narinfos ...)) + (return (map (lambda (item local) + (match (vhash-fold* cons '() item narinfos) + (() ;no substitutes + (comparison-report item 'inconclusive local '())) + ((narinfo) + (if local + (if ((compare item local) narinfo (first servers)) + (comparison-report item 'match + local (list narinfo)) + (comparison-report item 'mismatch + local (list narinfo))) + (comparison-report item 'inconclusive + local (list narinfo)))) + ((narinfos ...) + (let ((reference + (or local (select-reference item narinfos + servers)))) + (if (every (compare item reference) narinfos servers) + (comparison-report item 'match + local narinfos) + (comparison-report item 'mismatch + local narinfos)))))) + items + local)))) + +(define* (summarize-report comparison-report + #:key (hash->string + bytevector->nix-base32-string)) + "Write to the current error port a summary of REPORT, a +object." + (match comparison-report + (($ item 'mismatch local (narinfos ...)) (report (_ "~a contents differ:~%") item) (if local (report (_ " local hash: ~a~%") (hash->string local)) - (warning (_ "no local build for '~a'~%") item)) - + (report (_ " no local build for '~a'~%") item)) (for-each (lambda (narinfo) - (if narinfo - (report (_ " ~50a: ~a~%") - (uri->string (narinfo-uri narinfo)) - (hash->string - (narinfo-hash->sha256 (narinfo-hash narinfo)))) - (report (_ " ~50a: unavailable~%") - (uri->string (narinfo-uri narinfo))))) - narinfos)))) + (report (_ " ~50a: ~a~%") + (uri->string (narinfo-uri narinfo)) + (hash->string + (narinfo-hash->sha256 (narinfo-hash narinfo))))) + narinfos)) + (($ item 'inconclusive #f narinfos) + (warning (_ "could not challenge '~a': no local build~%") item)) + (($ item 'inconclusive locals ()) + (warning (_ "could not challenge '~a': no substitutes~%") item)) + (($ item 'match) + #t))) ;;; @@ -236,13 +272,14 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) #:use-substitutes? #f) (run-with-store store - (mlet* %store-monad ((items (mapm %store-monad - ensure-store-item files)) - (issues (discrepancies items urls))) - (for-each summarize-discrepancy issues) - (unless (null? issues) - (exit 2)) - (return (null? issues))) + (mlet* %store-monad ((items (mapm %store-monad + ensure-store-item files)) + (reports (compare-contents items urls))) + (for-each summarize-report reports) + + (exit (cond ((any comparison-report-mismatch? reports) 2) + ((every comparison-report-match? reports) 0) + (else 1)))) #:system system)))))))) ;;; challenge.scm ends here diff --git a/tests/challenge.scm b/tests/challenge.scm index 9505042a4..387d205a6 100644 --- a/tests/challenge.scm +++ b/tests/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -69,8 +69,15 @@ (built-derivations (list drv)) (mlet %store-monad ((hash (query-path-hash* out))) (with-derivation-narinfo* drv (sha256 => hash) - (>>= (discrepancies (list out) (%test-substitute-urls)) - (lift1 null? %store-monad)))))))) + (>>= (compare-contents (list out) (%test-substitute-urls)) + (match-lambda + ((report) + (return + (and (string=? out (comparison-report-item report)) + (bytevector=? + (comparison-report-local-sha256 report) + hash) + (comparison-report-match? report)))))))))))) (test-assertm "one discrepancy" (let ((text (random-text))) @@ -90,20 +97,57 @@ (modulo (+ b 1) 128)) w))) (with-derivation-narinfo* drv (sha256 => wrong-hash) - (>>= (discrepancies (list out) (%test-substitute-urls)) + (>>= (compare-contents (list out) (%test-substitute-urls)) (match-lambda - ((discrepancy) + ((report) (return - (and (string=? out (discrepancy-item discrepancy)) + (and (string=? out (comparison-report-item (pk report))) + (eq? 'mismatch (comparison-report-result report)) (bytevector=? hash - (discrepancy-local-sha256 - discrepancy)) - (match (discrepancy-narinfos discrepancy) + (comparison-report-local-sha256 + report)) + (match (comparison-report-narinfos report) ((bad) (bytevector=? wrong-hash (narinfo-hash->sha256 (narinfo-hash bad)))))))))))))))) +(test-assertm "inconclusive: no substitutes" + (mlet* %store-monad ((drv (gexp->derivation "foo" #~(mkdir #$output))) + (out -> (derivation->output-path drv)) + (_ (built-derivations (list drv))) + (hash (query-path-hash* out))) + (>>= (compare-contents (list out) (%test-substitute-urls)) + (match-lambda + ((report) + (return + (and (string=? out (comparison-report-item report)) + (comparison-report-inconclusive? report) + (null? (comparison-report-narinfos report)) + (bytevector=? (comparison-report-local-sha256 report) + hash)))))))) + +(test-assertm "inconclusive: no local build" + (let ((text (random-text))) + (mlet* %store-monad ((drv (gexp->derivation "something" + #~(list #$output #$text))) + (out -> (derivation->output-path drv)) + (hash -> (sha256 #vu8()))) + (with-derivation-narinfo* drv (sha256 => hash) + (>>= (compare-contents (list out) (%test-substitute-urls)) + (match-lambda + ((report) + (return + (and (string=? out (comparison-report-item report)) + (comparison-report-inconclusive? report) + (not (comparison-report-local-sha256 report)) + (match (comparison-report-narinfos report) + ((narinfo) + (bytevector=? (narinfo-hash->sha256 + (narinfo-hash narinfo)) + hash)))))))))))) + + (test-end) ;;; Local Variables: -- cgit v1.3 From 153b62957cd5b08ccc2440854c90b5693ba52eea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Jan 2017 00:03:32 +0100 Subject: challenge: Add '--verbose'. * guix/scripts/challenge.scm (summarize-report): Add #:verbose? parameter. [report-hashes]: New procedure. Use it. Honor VERBOSE? in the 'match case. (show-help, %options): Add '--verbose'. (guix-challenge): Honor it. --- doc/guix.texi | 5 +++++ guix/scripts/challenge.scm | 48 ++++++++++++++++++++++++++++++---------------- 2 files changed, 37 insertions(+), 16 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index c495e39f4..fa07aba5a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6412,6 +6412,11 @@ The one option that matters is: Consider @var{urls} the whitespace-separated list of substitute source URLs to compare to. +@item --verbose +@itemx -v +Show details about matches (identical contents) in addition to +information about mismatches. + @end table @node Invoking guix copy diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index f14e931d7..815bb789c 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -180,28 +180,35 @@ taken since we do not import the archives." local)))) (define* (summarize-report comparison-report - #:key (hash->string - bytevector->nix-base32-string)) + #:key + (hash->string bytevector->nix-base32-string) + verbose?) "Write to the current error port a summary of REPORT, a -object." +object. When VERBOSE?, display matches in addition to mismatches and +inconclusive reports." + (define (report-hashes item local narinfos) + (if local + (report (_ " local hash: ~a~%") (hash->string local)) + (report (_ " no local build for '~a'~%") item)) + (for-each (lambda (narinfo) + (report (_ " ~50a: ~a~%") + (uri->string (narinfo-uri narinfo)) + (hash->string + (narinfo-hash->sha256 (narinfo-hash narinfo))))) + narinfos)) + (match comparison-report (($ item 'mismatch local (narinfos ...)) (report (_ "~a contents differ:~%") item) - (if local - (report (_ " local hash: ~a~%") (hash->string local)) - (report (_ " no local build for '~a'~%") item)) - (for-each (lambda (narinfo) - (report (_ " ~50a: ~a~%") - (uri->string (narinfo-uri narinfo)) - (hash->string - (narinfo-hash->sha256 (narinfo-hash narinfo))))) - narinfos)) + (report-hashes item local narinfos)) (($ item 'inconclusive #f narinfos) (warning (_ "could not challenge '~a': no local build~%") item)) (($ item 'inconclusive locals ()) (warning (_ "could not challenge '~a': no substitutes~%") item)) - (($ item 'match) - #t))) + (($ item 'match local (narinfos ...)) + (when verbose? + (report (_ "~a contents match:~%") item) + (report-hashes item local narinfos))))) ;;; @@ -214,6 +221,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (display (_ " --substitute-urls=URLS compare build results with those at URLS")) + (display (_ " + -v, --verbose show details about successful comparisons")) (newline) (display (_ " -h, --help display this help and exit")) @@ -237,6 +246,11 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (alist-cons 'substitute-urls (string-tokenize arg) (alist-delete 'substitute-urls result)) + rest))) + (option '("verbose" #\v) #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'verbose? #t result) rest))))) (define %default-options @@ -256,7 +270,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (_ #f)) opts)) (system (assoc-ref opts 'system)) - (urls (assoc-ref opts 'substitute-urls))) + (urls (assoc-ref opts 'substitute-urls)) + (verbose? (assoc-ref opts 'verbose?))) (leave-on-EPIPE (with-store store ;; Disable grafts since substitute servers normally provide only @@ -275,7 +290,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (mlet* %store-monad ((items (mapm %store-monad ensure-store-item files)) (reports (compare-contents items urls))) - (for-each summarize-report reports) + (for-each (cut summarize-report <> #:verbose? verbose?) + reports) (exit (cond ((any comparison-report-mismatch? reports) 2) ((every comparison-report-match? reports) 0) -- cgit v1.3 From d9da3a757d3081403081577c4e07763c9b809043 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Jan 2017 15:32:43 +0100 Subject: guix build: Do not force 'build-cores', 'max-build-jobs', and 'max-silent-time'. This lets the daemon use its own default settings unless otherwise specified. * guix/scripts/build.scm (set-build-options-from-command-line): Do not provide default values for #:build-cores and #:max-build-jobs. (%default-options): Remove 'max-silent-time'. --- guix/scripts/build.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ccb4c275f..551275e89 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.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, 2017 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -344,8 +344,8 @@ options handled by 'set-build-options-from-command-line', and listed in #:keep-failed? (assoc-ref opts 'keep-failed?) #:keep-going? (assoc-ref opts 'keep-going?) #:rounds (assoc-ref opts 'rounds) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1) + #:build-cores (assoc-ref opts 'cores) + #:max-build-jobs (assoc-ref opts 'max-jobs) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) #:substitute-urls (assoc-ref opts 'substitute-urls) @@ -462,7 +462,6 @@ options handled by 'set-build-options-from-command-line', and listed in (substitutes? . #t) (build-hook? . #t) (print-build-trace? . #t) - (max-silent-time . 3600) (verbosity . 0))) (define (show-help) -- cgit v1.3 From 6da5bb7b1b7ddf4aa5a5efcb83250506bcd67036 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Jan 2017 22:28:24 +0100 Subject: guix build: Add '--repair'. * guix/scripts/build.scm (show-help, %options): Add '--repair'. * doc/guix.texi (Invoking guix gc): Mention 'guix build --repair'. (Additional Build Options): Document it. --- doc/guix.texi | 13 ++++++++++++- guix/scripts/build.scm | 8 ++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 55657ec81..bf9dbaa72 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2274,11 +2274,14 @@ traverses @emph{all the files in the store}, this command can take a long time, especially on systems with a slow disk drive. @cindex repairing the store +@cindex corruption, recovering from Using @option{--verify=repair} or @option{--verify=contents,repair} causes the daemon to try to repair corrupt store items by fetching substitutes for them (@pxref{Substitutes}). Because repairing is not atomic, and thus potentially dangerous, it is available only to the -system administrator. +system administrator. A lightweight alternative, when you know exactly +which items in the store are corrupt, is @command{guix build --repair} +(@pxref{Invoking guix build}). @item --optimize @cindex deduplication @@ -4859,6 +4862,14 @@ When used in conjunction with @option{--keep-failed}, the differing output is kept in the store, under @file{/gnu/store/@dots{}-check}. This makes it easy to look for differences between the two results. +@item --repair +@cindex repairing store items +@cindex corruption, recovering from +Attempt to repair the specified store items, if they are corrupt, by +re-downloading or rebuilding them. + +This operation is not atomic and thus restricted to @code{root}. + @item --derivations @itemx -d Return the derivation paths, not the output paths, of the given diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 551275e89..8326d64f4 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -485,6 +485,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -d, --derivations return the derivation paths of the given packages")) (display (_ " --check rebuild items to check for non-determinism issues")) + (display (_ " + --repair repair the specified items")) (display (_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) @@ -535,6 +537,12 @@ must be one of 'package', 'all', or 'transitive'~%") (alist-cons 'build-mode (build-mode check) result) rest))) + (option '("repair") #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'build-mode (build-mode repair) + result) + rest))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg -- cgit v1.3 From 840f38ba37af1d09eb1e896a6350d6ab7f6532d0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Jan 2017 16:57:56 +0100 Subject: guix environment, build: Allow absolute file names with '--root'. Reported by Chris Webber. * guix/scripts/build.scm (register-root): If ROOT is absolute, keep it as is. * guix/scripts/environment.scm (register-gc-root): Likewise. * tests/guix-environment.sh (expected): Add test. --- guix/scripts/build.scm | 6 ++++-- guix/scripts/environment.scm | 8 +++++--- tests/guix-environment.sh | 7 ++++++- 3 files changed, 15 insertions(+), 6 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8326d64f4..d7d71b7ab 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -99,8 +99,10 @@ found. Return #f if no build log was found." (define (register-root store paths root) "Register ROOT as an indirect GC root for all of PATHS." - (let* ((root (string-append (canonicalize-path (dirname root)) - "/" root))) + (let* ((root (if (string-prefix? "/" root) + root + (string-append (canonicalize-path (dirname root)) + "/" root)))) (catch 'system-error (lambda () (match paths diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1d3be6a84..a08367d1b 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015 David Thompson -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -531,8 +531,10 @@ message if any test fails." (define (register-gc-root target root) "Make ROOT an indirect root to TARGET. This is procedure is idempotent." - (let* ((root (string-append (canonicalize-path (dirname root)) - "/" root))) + (let* ((root (if (string-prefix? "/" root) + root + (string-append (canonicalize-path (dirname root)) + "/" root)))) (catch 'system-error (lambda () (symlink target root) diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 2b3bbfe03..911594912 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2015, 2016 Ludovic Courtès +# Copyright © 2015, 2016, 2017 Ludovic Courtès # # This file is part of GNU Guix. # @@ -74,7 +74,12 @@ test `readlink "$gcroot"` = "$expected" guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \ -- guile -c 1 test `readlink "$gcroot"` = "$expected" +rm "$gcroot" +# Same with an absolute file name. +guix environment --bootstrap -r "$PWD/$gcroot" --ad-hoc guile-bootstrap \ + -- guile -c 1 +test `readlink "$gcroot"` = "$expected" case "`uname -m`" in x86_64) -- cgit v1.3 From ac080e296e161e5145a7db75f7685b47c755c827 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Jan 2017 16:42:31 +0100 Subject: lint: Display PACKAGE@VERSION. * guix/scripts/lint.scm (run-checkers): Remove 'name' variable. Display PACKAGE@VERSION instead of PACKAGE-VERSION. --- guix/scripts/lint.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9b991786c..afc1369ad 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel @@ -959,12 +959,12 @@ or a list thereof") (define* (run-checkers package #:optional (checkers %checkers)) "Run the given CHECKERS on PACKAGE." - (let ((tty? (isatty? (current-error-port))) - (name (package-full-name package))) + (let ((tty? (isatty? (current-error-port)))) (for-each (lambda (checker) (when tty? - (format (current-error-port) "checking ~a [~a]...\x1b[K\r" - name (lint-checker-name checker)) + (format (current-error-port) "checking ~a@~a [~a]...\x1b[K\r" + (package-name package) (package-version package) + (lint-checker-name checker)) (force-output (current-error-port))) ((lint-checker-check checker) package)) checkers) -- cgit v1.3