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. --- tests/guix-package.sh | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'tests') 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 'tests') 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 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 'tests') 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 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 'tests') 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 384344198dcaa97847e66d3dd82f279ede08d690 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Jan 2017 22:33:46 +0100 Subject: file-systems: 'file-system-needed-for-boot?' is #t for parents of the store. Suggested by John Darrington . * gnu/system/file-systems.scm (%not-slash): New variable. (file-prefix?): New procedure. (file-system-needed-for-boot?): Use it to check whether FS holds the store. * tests/file-systems.scm ("file-system-needed-for-boot?"): New test. * gnu/tests/install.scm (%separate-store-os)[file-systems]: Remove 'needed-for-boot?' field for "/gnu". --- gnu/system/file-systems.scm | 38 +++++++++++++++++++++++++++++++++----- gnu/tests/install.scm | 5 ++--- tests/file-systems.scm | 24 +++++++++++++++++++++++- 3 files changed, 58 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 4cc1221eb8..fa56853fd1 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -95,11 +95,39 @@ (dependencies file-system-dependencies ; list of (default '()))) ; or -(define-inlinable (file-system-needed-for-boot? fs) - "Return true if FS has the 'needed-for-boot?' flag set, or if it's the root -file system." +(define %not-slash + (char-set-complement (char-set #\/))) + +(define (file-prefix? file1 file2) + "Return #t if FILE1 denotes the name of a file that is a parent of FILE2, +where both FILE1 and FILE2 are absolute file name. For example: + + (file-prefix? \"/gnu\" \"/gnu/store\") + => #t + + (file-prefix? \"/gn\" \"/gnu/store\") + => #f +" + (and (string-prefix? "/" file1) + (string-prefix? "/" file2) + (let loop ((file1 (string-tokenize file1 %not-slash)) + (file2 (string-tokenize file2 %not-slash))) + (match file1 + (() + #t) + ((head1 tail1 ...) + (match file2 + ((head2 tail2 ...) + (and (string=? head1 head2) (loop tail1 tail2))) + (() + #f))))))) + +(define (file-system-needed-for-boot? fs) + "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the +store--e.g., if FS is the root file system." (or (%file-system-needed-for-boot? fs) - (string=? "/" (file-system-mount-point fs)))) + (and (file-prefix? (file-system-mount-point fs) (%store-prefix)) + (not (memq 'bind-mount (file-system-flags fs)))))) (define (file-system->spec fs) "Return a list corresponding to file-system FS that can be passed to the diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index ae54154c5c..4e8d594054 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.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. ;;; @@ -257,8 +257,7 @@ build (current-guix) and then store a couple of full system images.") (device "store-fs") (title 'label) (mount-point "/gnu") - (type "ext4") - (needed-for-boot? #t)) ;definitely! + (type "ext4")) %base-file-systems)) (users %base-user-accounts) (services (cons (service marionette-service-type diff --git a/tests/file-systems.scm b/tests/file-systems.scm index aed27e89c2..fd1599e132 100644 --- a/tests/file-systems.scm +++ b/tests/file-systems.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. ;;; @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (test-file-systems) + #:use-module (guix store) #:use-module (gnu system file-systems) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors)) @@ -50,4 +51,25 @@ (string-contains message "invalid UUID") (equal? form '(uuid "foobar")))))) +(test-assert "file-system-needed-for-boot?" + (let-syntax ((dummy-fs (syntax-rules () + ((_ directory) + (file-system + (device "foo") + (mount-point directory) + (type "ext4")))))) + (parameterize ((%store-prefix "/gnu/guix/store")) + (and (file-system-needed-for-boot? (dummy-fs "/")) + (file-system-needed-for-boot? (dummy-fs "/gnu")) + (file-system-needed-for-boot? (dummy-fs "/gnu/guix")) + (file-system-needed-for-boot? (dummy-fs "/gnu/guix/store")) + (not (file-system-needed-for-boot? + (dummy-fs "/gnu/guix/store/foo"))) + (not (file-system-needed-for-boot? (dummy-fs "/gn"))) + (not (file-system-needed-for-boot? + (file-system + (inherit (dummy-fs (%store-prefix))) + (device "/foo") + (flags '(bind-mount read-only))))))))) + (test-end) -- 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 'tests') 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 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 'tests') 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