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') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 6eba9e0008..3e056fda9b 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.2.3 From dd1141eba2cd92cde0fb7c4dc736fac533886a8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Jan 2017 15:34:11 +0100 Subject: http-client: Improve error reporting. * guix/http-client.scm (http-fetch): Change message in &message condition to include URI, CODE, and the reason phrase. --- guix/http-client.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index cc3acc9587..0090783524 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -276,7 +276,12 @@ Raise an '&http-get-error' condition if downloading fails." (code code) (reason (response-reason-phrase resp))) (&message - (message "download failed")))))))))) + (message + (format + #f + (_ "~a: HTTP download failed: ~a (~s)") + (uri->string uri) code + (response-reason-phrase resp)))))))))))) ;;; -- cgit v1.2.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') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 3e056fda9b..9e49c53635 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.2.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') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 90e7fa2298..9e5b7f3c75 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 06f49daca8..ee06e47fe9 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 68a1946aa0..5ecb33193f 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.2.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') diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 0d2e7089aa..58a7377141 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 38048ceebc..cebc404d1c 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 32af767dc4..7ed75e5079 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 79171fcb6c..396ea14ebc 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 2b5aa796d4..3fbfec3793 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.2.3 From 5c6a30c5119ffd5702c02e07e7f04669a8f225bb Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 17 Dec 2016 00:57:24 +0100 Subject: git download: Remove redundant argument in 'gexp->derivation' call. * guix/git-download.scm (git-fetch): Call 'gexp->derivation' with only one '#:local-build?' keyword argument. --- guix/git-download.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index fca44f552a..62e625c715 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -109,8 +109,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:guile-for-build guile - #:local-build? #t))) + #:guile-for-build guile))) (define (git-version version revision commit) "Return the version string for packages using git-download." -- cgit v1.2.3 From dc673fa1131fb5d1e5ca29acb4a693cfb906986f Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 17 Dec 2016 15:12:19 +0100 Subject: derivations: Make record datatype immutable. * guix/derivations.scm (): Make it immutable. (derivation): Use generic 'set-field' instead of ad-hoc functional setter. --- guix/derivations.scm | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index d5e4b5730b..b712c508e5 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2016, 2017 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. ;;; @@ -120,7 +121,7 @@ ;;; Nix derivations, as implemented in Nix's `derivations.cc'. ;;; -(define-record-type +(define-immutable-record-type (make-derivation outputs inputs sources system builder args env-vars file-name) derivation? @@ -817,14 +818,6 @@ output should not be used." e outputs))) - (define (set-file-name drv file) - ;; Set FILE as the 'file-name' field of DRV. - (match drv - (($ outputs inputs sources system builder - args env-vars) - (make-derivation outputs inputs sources system builder - args env-vars file)))) - (define input->derivation-input (match-lambda (((? derivation? drv)) @@ -872,9 +865,9 @@ output should not be used." (let* ((file (add-text-to-store store (string-append name ".drv") (derivation->string drv) (map derivation-input-path inputs))) - (drv (set-file-name drv file))) - (hash-set! %derivation-cache file drv) - drv))) + (drv* (set-field drv (derivation-file-name) file))) + (hash-set! %derivation-cache file drv*) + drv*))) (define* (map-derivation store drv mapping #:key (system (%current-system))) -- cgit v1.2.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') diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 58a7377141..59ade0a8c1 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.2.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') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 590d8f1099..9ab4fbe2a9 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.2.3 From e7ff05438f6044eb452b6dcd8b05b45afbc61496 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 12:07:10 +0100 Subject: ui: Factorize error-reporting wrapper code. * guix/ui.scm (augmented-system-error-handler): New procedure. (error-reporting-wrapper): New macro. (symlink, copy-file): Define using 'error-reporting-wrapper'. --- guix/ui.scm | 49 +++++++++++++++++++++++-------------------------- 1 file changed, 23 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 7d4c437354..03196dbeaf 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -332,39 +332,36 @@ Report bugs to: ~a.") %guix-bug-report-address) General help using GNU software: ")) (newline)) +(define (augmented-system-error-handler file) + "Return a 'system-error' handler that mentions FILE in its message." + (lambda (key proc fmt args errno) + ;; Augment the FMT and ARGS with information about TARGET (this + ;; information is missing as of Guile 2.0.11, making the exception + ;; uninformative.) + (apply throw key proc "~A: ~S" + (list (strerror (car errno)) file) + (list errno)))) + +(define-syntax-rule (error-reporting-wrapper proc (args ...) file) + "Wrap PROC such that its 'system-error' exceptions are augmented to mention +FILE." + (let ((real-proc (@ (guile) proc))) + (lambda (args ...) + (catch 'system-error + (lambda () + (real-proc args ...)) + (augmented-system-error-handler file))))) + (set! symlink ;; We 'set!' the global binding because (gnu build ...) modules and similar ;; typically don't use (guix ui). - (let ((real-symlink (@ (guile) symlink))) - (lambda (target link) - "This is a 'symlink' replacement that provides proper error reporting." - (catch 'system-error - (lambda () - (real-symlink target link)) - (lambda (key proc fmt args errno) - ;; Augment the FMT and ARGS with information about LINK (this - ;; information is missing as of Guile 2.0.11, making the exception - ;; uninformative.) - (apply throw key proc "~A: ~S" - (list (strerror (car errno)) link) - (list errno))))))) + (error-reporting-wrapper symlink (source target) target)) (set! copy-file ;; Note: here we use 'set!', not #:replace, because UIs typically use ;; 'copy-recursively', which doesn't use (guix ui). - (let ((real-copy-file (@ (guile) copy-file))) - (lambda (source target) - "This is a 'copy-file' replacement that provides proper error reporting." - (catch 'system-error - (lambda () - (real-copy-file source target)) - (lambda (key proc fmt args errno) - ;; Augment the FMT and ARGS with information about TARGET (this - ;; information is missing as of Guile 2.0.11, making the exception - ;; uninformative.) - (apply throw key proc "~A: ~S" - (list (strerror (car errno)) target) - (list errno))))))) + (error-reporting-wrapper copy-file (source target) target)) + (define (make-regexp* regexp . flags) "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error -- cgit v1.2.3 From 6d30b1b2ca92705a6f3c06ddaf8ccf06466089d3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 12:09:01 +0100 Subject: ui: Wrap 'canonicalize-path' for better error reporting. Reported by Christopher Baines. * guix/ui.scm (canonicalize-path): New procedure. --- guix/ui.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 03196dbeaf..6247944068 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -362,6 +362,9 @@ FILE." ;; 'copy-recursively', which doesn't use (guix ui). (error-reporting-wrapper copy-file (source target) target)) +(set! canonicalize-path + (error-reporting-wrapper canonicalize-path (file) file)) + (define (make-regexp* regexp . flags) "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error -- cgit v1.2.3 From 4cd5ec801bb6c82cc1df2c4ac419d89614aa5d1b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 18:14:19 +0100 Subject: import: github: Fix regression on the /releases retrieval. Fixes a regression introduced in 62bd24db39a86f80242f923eb4cc2f18f3b02c67, which introduced a call to 'hash-table->alist'. * guix/import/github.scm (json-fetch*): New procedure. (latest-released-version): Use it. --- guix/import/github.scm | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index 01452b12e3..a41511aff6 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -19,16 +19,28 @@ (define-module (guix import github) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (json) #:use-module (guix utils) #:use-module ((guix download) #:prefix download:) #:use-module (guix import utils) - #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) + #:use-module (guix http-client) #:use-module (web uri) #:export (%github-updater)) +(define (json-fetch* url) + "Return a representation of the JSON resource URL (a list or hash table), or +#f if URL returns 404." + (guard (c ((and (http-get-error? c) + (= 404 (http-get-error-code c))) + #f)) ;"expected" if package is unknown + (let* ((port (http-fetch url)) + (result (json->scm port))) + (close-port port) + result))) + (define (find-extension url) "Return the extension of the archive e.g. '.tar.gz' given a URL, or false if none is recognized" @@ -125,7 +137,7 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" "https://api.github.com/repos/" (github-user-slash-repository url) "/releases")) - (json (json-fetch + (json (json-fetch* (if token (string-append api-url "?access_token=" token) api-url)))) -- cgit v1.2.3 From 608a50b66c73d5bdfd224195b839e01b781c354c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 18:22:53 +0100 Subject: http-client: Provide 'User-Agent' header by default. * guix/http-client.scm (http-fetch): Add #:headers parameter and honor it. Rename 'auth-header' to 'headers'. * guix/import/github.scm (json-fetch*): Add comment about required User-Agent. --- guix/http-client.scm | 26 ++++++++++++++------------ guix/import/github.scm | 1 + 2 files changed, 15 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index 0090783524..78d39a0208 100644 --- a/guix/http-client.scm +++ b/guix/http-client.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 © 2015 Mark H Weaver ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; @@ -223,13 +223,14 @@ or if EOF is reached." 'shutdown (const #f)) (define* (http-fetch uri #:key port (text? #f) (buffered? #t) - keep-alive? (verify-certificate? #t)) + keep-alive? (verify-certificate? #t) + (headers '((user-agent . "GNU Guile")))) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be -reused for future HTTP requests. +reused for future HTTP requests. HEADERS is an alist of extra HTTP headers. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. @@ -240,13 +241,14 @@ Raise an '&http-get-error' condition if downloading fails." (let ((port (or port (open-connection-for-uri uri #:verify-certificate? verify-certificate?))) - (auth-header (match (uri-userinfo uri) - ((? string? str) - (list (cons 'Authorization - (string-append "Basic " - (base64-encode - (string->utf8 str)))))) - (_ '())))) + (headers (match (uri-userinfo uri) + ((? string? str) + (cons (cons 'Authorization + (string-append "Basic " + (base64-encode + (string->utf8 str)))) + headers)) + (_ headers)))) (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF)) (let*-values (((resp data) @@ -254,10 +256,10 @@ Raise an '&http-get-error' condition if downloading fails." (if (guile-version>? "2.0.7") (http-get uri #:streaming? #t #:port port #:keep-alive? #t - #:headers auth-header) ; 2.0.9+ + #:headers headers) ; 2.0.9+ (http-get* uri #:decode-body? text? ; 2.0.7 #:keep-alive? #t - #:port port #:headers auth-header))) + #:port port #:headers headers))) ((code) (response-code resp))) (case code diff --git a/guix/import/github.scm b/guix/import/github.scm index a41511aff6..df5a6b0e08 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -36,6 +36,7 @@ (guard (c ((and (http-get-error? c) (= 404 (http-get-error-code c))) #f)) ;"expected" if package is unknown + ;; Note: github.com returns 403 if we omit a 'User-Agent' header. (let* ((port (http-fetch url)) (result (json->scm port))) (close-port port) -- cgit v1.2.3 From d8c8e423ed67897a8cc236e68658baacdce1b5fd Mon Sep 17 00:00:00 2001 From: ng0 Date: Thu, 12 Jan 2017 00:39:25 +0000 Subject: licenses: Add wtfpl2. * guix/licenses.scm (wtfpl2): New variable. Signed-off-by: Leo Famulari --- guix/licenses.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 1e19300586..7b2ac2d311 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -8,7 +8,7 @@ ;;; Copyright © 2016 Leo Famulari ;;; Copyright © 2016 Fabian Harfert ;;; Copyright © 2016 Rene Saavedra -;;; Copyright © 2016 ng0 +;;; Copyright © 2016, 2017 ng0 ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,7 +74,8 @@ x11 x11-style zpl2.1 zlib - fsf-free)) + fsf-free + wtfpl2)) (define-record-type (license name uri comment) @@ -450,6 +451,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://unlicense.org/" "https://www.gnu.org/licenses/license-list.html#Unlicense")) +(define wtfpl2 + (license "WTFPL 2" + "http://www.wtfpl.net" + "http://www.wtfpl.net/about/")) + (define x11 (license "X11" "http://directory.fsf.org/wiki/License:X11" -- cgit v1.2.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') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 9ab4fbe2a9..f14e931d74 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 9505042a45..387d205a64 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.2.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') diff --git a/doc/guix.texi b/doc/guix.texi index c495e39f42..fa07aba5ad 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 f14e931d74..815bb789c3 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.2.3 From deac976d3d26c7b85b9c90efb424b0aa94f1027c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Jan 2017 15:13:07 +0100 Subject: daemon: Client settings no longer override daemon settings. Fixes . * nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0x161. * nix/nix-daemon/nix-daemon.cc (performOp): "build-max-jobs", "build-max-silent-time", and "build-cores" are no longer read upfront; instead, read them from the key/value list at the end. * nix/nix-daemon/guix-daemon.cc (main): Explicitly set 'settings.maxBuildJobs'. * guix/store.scm (%protocol-version): Bump to #x161. (set-build-options): #:max-build-jobs, #:max-silent-time, and #:build-cores now default to #f. Adjust handshake to new protocol. * tests/store.scm ("build-cores"): New test. * tests/guix-daemon.sh: Add test for default "build-cores" value. --- guix/store.scm | 34 +++++++++++++++++++++++++--------- nix/libstore/worker-protocol.hh | 2 +- nix/nix-daemon/guix-daemon.cc | 5 +++-- nix/nix-daemon/nix-daemon.cc | 16 ++++++++++++---- tests/guix-daemon.sh | 29 ++++++++++++++++++++++++++++- tests/store.scm | 27 ++++++++++++++++++++++++++- 6 files changed, 95 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 49549d0771..7152a5556a 100644 --- a/guix/store.scm +++ b/guix/store.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. ;;; @@ -138,7 +138,7 @@ direct-store-path log-file)) -(define %protocol-version #x10f) +(define %protocol-version #x161) (define %worker-magic-1 #x6e697863) ; "nixc" (define %worker-magic-2 #x6478696f) ; "dxio" @@ -537,14 +537,14 @@ encoding conversion errors." #:key keep-failed? keep-going? fallback? (verbosity 0) rounds ;number of build rounds - (max-build-jobs 1) + max-build-jobs timeout - (max-silent-time 3600) + max-silent-time (use-build-hook? #t) (build-verbosity 0) (log-type 0) (print-build-trace #t) - (build-cores (current-processor-count)) + build-cores (use-substitutes? #t) ;; Client-provided substitute URLs. If it is #f, @@ -570,21 +570,37 @@ encoding conversion errors." ...))))) (write-int (operation-id set-options) socket) (send (boolean keep-failed?) (boolean keep-going?) - (boolean fallback?) (integer verbosity) - (integer max-build-jobs) (integer max-silent-time)) + (boolean fallback?) (integer verbosity)) + (when (< (nix-server-minor-version server) #x61) + (let ((max-build-jobs (or max-build-jobs 1)) + (max-silent-time (or max-silent-time 3600))) + (send (integer max-build-jobs) (integer max-silent-time)))) (when (>= (nix-server-minor-version server) 2) (send (boolean use-build-hook?))) (when (>= (nix-server-minor-version server) 4) (send (integer build-verbosity) (integer log-type) (boolean print-build-trace))) - (when (>= (nix-server-minor-version server) 6) - (send (integer build-cores))) + (when (and (>= (nix-server-minor-version server) 6) + (< (nix-server-minor-version server) #x61)) + (let ((build-cores (or build-cores (current-processor-count)))) + (send (integer build-cores)))) (when (>= (nix-server-minor-version server) 10) (send (boolean use-substitutes?))) (when (>= (nix-server-minor-version server) 12) (let ((pairs `(,@(if timeout `(("build-timeout" . ,(number->string timeout))) '()) + ,@(if max-silent-time + `(("build-max-silent-time" + . ,(number->string max-silent-time))) + '()) + ,@(if max-build-jobs + `(("build-max-jobs" + . ,(number->string max-build-jobs))) + '()) + ,@(if build-cores + `(("build-cores" . ,(number->string build-cores))) + '()) ,@(if substitute-urls `(("substitute-urls" . ,(string-join substitute-urls))) diff --git a/nix/libstore/worker-protocol.hh b/nix/libstore/worker-protocol.hh index bdeaca2e3a..efe9eadf23 100644 --- a/nix/libstore/worker-protocol.hh +++ b/nix/libstore/worker-protocol.hh @@ -6,7 +6,7 @@ namespace nix { #define WORKER_MAGIC_1 0x6e697863 #define WORKER_MAGIC_2 0x6478696f -#define PROTOCOL_VERSION 0x160 +#define PROTOCOL_VERSION 0x161 #define GET_PROTOCOL_MAJOR(x) ((x) & 0xff00) #define GET_PROTOCOL_MINOR(x) ((x) & 0x00ff) diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index d5d33a587a..aa47a290d2 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2012, 2013, 2014, 2015, 2016 Ludovic Courtès + Copyright (C) 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès This file is part of GNU Guix. @@ -301,8 +301,9 @@ main (int argc, char *argv[]) /* Turn automatic deduplication on by default. */ settings.autoOptimiseStore = true; - /* Default to using as many cores as possible. */ + /* Default to using as many cores as possible and one job at a time. */ settings.buildCores = 0; + settings.maxBuildJobs = 1; argvSaved = argv; diff --git a/nix/nix-daemon/nix-daemon.cc b/nix/nix-daemon/nix-daemon.cc index 47b67d5863..79580ffb48 100644 --- a/nix/nix-daemon/nix-daemon.cc +++ b/nix/nix-daemon/nix-daemon.cc @@ -549,8 +549,12 @@ static void performOp(bool trusted, unsigned int clientVersion, settings.keepGoing = readInt(from) != 0; settings.set("build-fallback", readInt(from) ? "true" : "false"); verbosity = (Verbosity) readInt(from); - settings.set("build-max-jobs", std::to_string(readInt(from))); - settings.set("build-max-silent-time", std::to_string(readInt(from))); + + if (GET_PROTOCOL_MINOR(clientVersion) < 0x61) { + settings.set("build-max-jobs", std::to_string(readInt(from))); + settings.set("build-max-silent-time", std::to_string(readInt(from))); + } + if (GET_PROTOCOL_MINOR(clientVersion) >= 2) settings.useBuildHook = readInt(from) != 0; if (GET_PROTOCOL_MINOR(clientVersion) >= 4) { @@ -558,7 +562,8 @@ static void performOp(bool trusted, unsigned int clientVersion, logType = (LogType) readInt(from); settings.printBuildTrace = readInt(from) != 0; } - if (GET_PROTOCOL_MINOR(clientVersion) >= 6) + if (GET_PROTOCOL_MINOR(clientVersion) >= 6 + && GET_PROTOCOL_MINOR(clientVersion) < 0x61) settings.set("build-cores", std::to_string(readInt(from))); if (GET_PROTOCOL_MINOR(clientVersion) >= 10) settings.set("build-use-substitutes", readInt(from) ? "true" : "false"); @@ -567,7 +572,10 @@ static void performOp(bool trusted, unsigned int clientVersion, for (unsigned int i = 0; i < n; i++) { string name = readString(from); string value = readString(from); - if (name == "build-timeout" || name == "build-repeat" || name == "use-ssh-substituter") + if (name == "build-timeout" || name == "build-max-silent-time" + || name == "build-max-jobs" || name == "build-cores" + || name == "build-repeat" + || name == "use-ssh-substituter") settings.set(name, value); else settings.set(trusted ? name : "untrusted-" + name, value); diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 7122eed0e6..fde49e25a2 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2014, 2015, 2016 Ludovic Courtès +# Copyright © 2012, 2014, 2015, 2016, 2017 Ludovic Courtès # # This file is part of GNU Guix. # @@ -118,3 +118,30 @@ guile -c " (clear-failed-paths store (list out)) (null? (query-failed-paths store))))))) #:guile-for-build (%guile-for-build)) " + +kill "$daemon_pid" + + +# Make sure the daemon's default 'build-cores' setting is honored. + +guix-daemon --listen="$socket" --disable-chroot --cores=42 & +daemon_pid=$! + +GUIX_DAEMON_SOCKET="$socket" \ +guile -c ' + (use-modules (guix) (gnu packages) (guix tests)) + + (with-store store + (let* ((build (add-text-to-store store "build.sh" + "echo $NIX_BUILD_CORES > $out")) + (bash (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (drv (derivation store "the-thing" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("x" . ,(random-text)))))) + (and (build-derivations store (list drv)) + (exit + (= 42 (pk (call-with-input-file (derivation->output-path drv) + read)))))))' diff --git a/tests/store.scm b/tests/store.scm index 123ea8a787..983766d862 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 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -948,4 +948,29 @@ (string=? (derivation-file-name d) (path-info-deriver (query-path-info %store o)))))) +(test-equal "build-cores" + (list 0 42) + (with-store store + (let* ((build (add-text-to-store store "build.sh" + "echo $NIX_BUILD_CORES > $out")) + (bash (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (drv1 (derivation store "the-thing" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("x" . ,(random-text))))) + (drv2 (derivation store "the-thing" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("x" . ,(random-text)))))) + (and (build-derivations store (list drv1)) + (begin + (set-build-options store #:build-cores 42) + (build-derivations store (list drv2))) + (list (call-with-input-file (derivation->output-path drv1) + read) + (call-with-input-file (derivation->output-path drv2) + read)))))) + (test-end "store") -- cgit v1.2.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') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ccb4c275fc..551275e89f 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.2.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') diff --git a/doc/guix.texi b/doc/guix.texi index 55657ec81c..bf9dbaa726 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 551275e89f..8326d64f48 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.2.3 From 849a1b8133263741754dfec7a424d9de05a165ef Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 15 Jan 2017 09:25:52 +0000 Subject: profiles: Export 'ca-certificate-bundle'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/profiles.scm: Export ca-certificate-bundle, such that it can be used in other G-expressions. This is useful where these G-expressions run programs that require a ca-certificate-bundle, e.g. git. Signed-off-by: Ludovic Courtès --- guix/profiles.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index e7707b6543..495a9e2e7c 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -92,6 +92,7 @@ profile-manifest package->manifest-entry packages->manifest + ca-certificate-bundle %default-profile-hooks profile-derivation -- cgit v1.2.3 From 90ad5c8836138b7fd4d1bd0243dfa8b30ae0cf21 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Jan 2017 21:59:00 +0100 Subject: grafts: Actually cache grafts during the derivation DAG traversal. This fixes a regression introduced in d38bc9a9f6feefc465964531520fee5663a12f48 whereby the cache was effectively disabled. Reported by Thomas Danckaert . * guix/grafts.scm (with-cache): In the cache miss case, wrap body in 'mbegin'. --- guix/grafts.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index 2006d3908e..b60c8cfd90 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -222,8 +222,9 @@ available." (return result)) (#f ;cache miss (mlet %state-monad ((result (begin exp ...))) - (set-current-state (vhash-consq key result cache)) - (return result)))))) + (mbegin %state-monad + (set-current-state (vhash-consq key result cache)) + (return result))))))) (define* (cumulative-grafts store drv grafts references -- cgit v1.2.3 From 0aeed5e310504a9ef2cf6a2b2a7e76086eb8c2fc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Jan 2017 22:05:43 +0100 Subject: grafts: Preserve the cache across recursive calls. Before this commit, we'd lose the cache across recursive calls to 'cumulative-grafts', which isn't great performance-wise. This bug was already present before d38bc9a9f6feefc465964531520fee5663a12f48. * guix/grafts.scm (with-cache): In the miss case, call 'current-state' after EXP has been evaluated. --- guix/grafts.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index b60c8cfd90..e14a40f8d1 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -221,7 +221,8 @@ available." ((_ . result) ;cache hit (return result)) (#f ;cache miss - (mlet %state-monad ((result (begin exp ...))) + (mlet %state-monad ((result (begin exp ...)) + (cache (current-state))) (mbegin %state-monad (set-current-state (vhash-consq key result cache)) (return result))))))) -- cgit v1.2.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') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8326d64f48..d7d71b7ab9 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 1d3be6a84f..a08367d1b1 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 2b3bbfe036..9115949123 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.2.3 From d18b79fed895b9ca5cdb3a9a68c8e02bdaef30d8 Mon Sep 17 00:00:00 2001 From: Mathieu OTHACEHE Date: Tue, 17 Jan 2017 09:17:30 +0100 Subject: import: github: Catch HTTP 403 error during fetch. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/github.scm (json-fetch*): Catch 403 HTTP error that may be raised if a github token has not been set. Signed-off-by: Mathieu OTHACEHE Signed-off-by: Ludovic Courtès --- guix/import/github.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index df5a6b0e08..1e0bb53d9a 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -32,10 +32,13 @@ (define (json-fetch* url) "Return a representation of the JSON resource URL (a list or hash table), or -#f if URL returns 404." +#f if URL returns 403 or 404." (guard (c ((and (http-get-error? c) - (= 404 (http-get-error-code c))) - #f)) ;"expected" if package is unknown + (let ((error (http-get-error-code c))) + (or (= 403 error) + (= 404 error)))) + #f)) ;; "expected" if there is an authentification error (403), + ;; or if package is unknown (404). ;; Note: github.com returns 403 if we omit a 'User-Agent' header. (let* ((port (http-fetch url)) (result (json->scm port))) -- cgit v1.2.3 From 57f068bec5349e250ce321262609ca8978a81f7f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Jan 2017 23:20:57 +0100 Subject: syscalls: Extract 'bytes->string'. * guix/build/syscalls.scm (bytes->string): New procedure. (bytevector->string-list): Use it. --- guix/build/syscalls.scm | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 2e37846ff0..c06013cd08 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -900,6 +900,15 @@ bytevector BV at INDEX." ;; The most terrible interface, live from Scheme. (syscall->procedure int "ioctl" (list int unsigned-long '*))) +(define (bytes->string bytes) + "Read BYTES, a list of bytes, and return the null-terminated string decoded +from there, or #f if that would be an empty string." + (match (take-while (negate zero?) bytes) + (() + #f) + (non-zero + (list->string (map integer->char non-zero))))) + (define (bytevector->string-list bv stride len) "Return the null-terminated strings found in BV every STRIDE bytes. Read at most LEN bytes from BV." @@ -911,9 +920,7 @@ most LEN bytes from BV." (reverse result)) (_ (loop (drop bytes stride) - (cons (list->string (map integer->char - (take-while (negate zero?) bytes))) - result)))))) + (cons (bytes->string bytes) result)))))) (define* (network-interface-names #:optional sock) "Return the names of existing network interfaces. This is typically limited -- cgit v1.2.3 From 150309726f221c9b982e594466d35f5b895391d5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Jan 2017 23:21:25 +0100 Subject: syscalls: Add utmpx procedures and data structure. * guix/build/syscalls.scm (): New record type. (%utmpx): New C struct. (login-type): New bits. (setutxent, endutxent, getutxent, utmpx-entries): New procedures. --- guix/build/syscalls.scm | 113 +++++++++++++++++++++++++++++++++++++++++++++++- tests/syscalls.scm | 13 +++++- 2 files changed, 124 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index c06013cd08..475fc96490 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -25,6 +25,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -126,7 +127,22 @@ window-size-x-pixels window-size-y-pixels terminal-window-size - terminal-columns)) + terminal-columns + + utmpx? + utmpx-login-type + utmpx-pid + utmpx-line + utmpx-id + utmpx-user + utmpx-host + utmpx-termination-status + utmpx-exit-status + utmpx-session-id + utmpx-time + utmpx-address + login-type + utmpx-entries)) ;;; Commentary: ;;; @@ -1487,4 +1503,99 @@ always a positive integer." (fall-back) (apply throw args)))))) + +;;; +;;; utmpx. +;;; + +(define-record-type + (utmpx type pid line id user host termination exit + session time address) + utmpx? + (type utmpx-login-type) ;login-type + (pid utmpx-pid) + (line utmpx-line) ;device name + (id utmpx-id) + (user utmpx-user) ;user name + (host utmpx-host) ;host name | #f + (termination utmpx-termination-status) + (exit utmpx-exit-status) + (session utmpx-session-id) ;session ID, for windowing + (time utmpx-time) ;entry time + (address utmpx-address)) + +(define-c-struct %utmpx ; + sizeof-utmpx + (lambda (type pid line id user host termination exit session + seconds useconds address %reserved) + (utmpx type pid + (bytes->string line) id + (bytes->string user) + (bytes->string host) termination exit + session + (make-time time-utc (* 1000 useconds) seconds) + address)) + read-utmpx + write-utmpx! + (type short) + (pid int) + (line (array uint8 32)) + (id (array uint8 4)) + (user (array uint8 32)) + (host (array uint8 256)) + (termination short) + (exit short) + (session int32) + (time-seconds int32) + (time-useconds int32) + (address-v6 (array int32 4)) + (%reserved (array uint8 20))) + +(define-bits login-type + %unused-login-type->symbols + (define EMPTY 0) ;No valid user accounting information. + (define RUN_LVL 1) ;The system's runlevel. + (define BOOT_TIME 2) ;Time of system boot. + (define NEW_TIME 3) ;Time after system clock changed. + (define OLD_TIME 4) ;Time when system clock changed. + + (define INIT_PROCESS 5) ;Process spawned by the init process. + (define LOGIN_PROCESS 6) ;Session leader of a logged in user. + (define USER_PROCESS 7) ;Normal process. + (define DEAD_PROCESS 8) ;Terminated process. + + (define ACCOUNTING 9)) ;System accounting. + +(define setutxent + (let ((proc (syscall->procedure void "setutxent" '()))) + (lambda () + "Open the user accounting database." + (proc)))) + +(define endutxent + (let ((proc (syscall->procedure void "endutxent" '()))) + (lambda () + "Close the user accounting database." + (proc)))) + +(define getutxent + (let ((proc (syscall->procedure '* "getutxent" '()))) + (lambda () + "Return the next entry from the user accounting database." + (let ((ptr (proc))) + (if (null-pointer? ptr) + #f + (read-utmpx (pointer->bytevector ptr sizeof-utmpx))))))) + +(define (utmpx-entries) + "Return the list of entries read from the user accounting database." + (setutxent) + (let loop ((entries '())) + (match (getutxent) + (#f + (endutxent) + (reverse entries)) + ((? utmpx? entry) + (loop (cons entry entries)))))) + ;;; syscalls.scm ends here diff --git a/tests/syscalls.scm b/tests/syscalls.scm index e4ef32c522..fb2c8e7100 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; ;;; This file is part of GNU Guix. @@ -441,6 +441,17 @@ (> (terminal-columns (open-input-string "Join us now, share the software!")) 0)) +(test-assert "utmpx-entries" + (match (utmpx-entries) + (((? utmpx? entries) ...) + (every (lambda (entry) + (match (utmpx-user entry) + ((? string?) + (> (utmpx-pid entry) 0)) + (#f ;might be DEAD_PROCESS + #t))) + entries)))) + (test-end) (false-if-exception (delete-file temp-file)) -- cgit v1.2.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') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9b991786c3..afc1369ad1 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.2.3