diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 38 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 21 | ||||
| -rw-r--r-- | guix/scripts/challenge.scm | 185 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/perform-download.scm | 37 |
7 files changed, 195 insertions, 109 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 6eba9e0008..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 <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; 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 <http://bugs.gnu.org/12202>. +(module-autoload! (current-module) + '(guix docker) '(build-docker-image)) + ;;; ;;; Command-line options. @@ -53,7 +57,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 +258,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 +356,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) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ccb4c275fc..d7d71b7ab9 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 <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -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 @@ -344,8 +346,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 +464,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) @@ -487,6 +488,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (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")) (display (_ " @@ -536,6 +539,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 diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 590d8f1099..815bb789c3 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 <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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> - (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 <narinfo> +;; Representation of a comparison report for ITEM. +(define-record-type <comparison-report> + (%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 <narinfo> + +(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 <comparison-report> 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)))))) - (() - (leave (_ "no substitutes for '~a'~%") item)))) + (narinfo-hash->sha256 (narinfo-hash first)))))))) (mlet* %store-monad ((local (mapm %store-monad query-locally-built-hash items)) @@ -130,42 +154,61 @@ 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 <discrepancy> -object that denotes a hash mismatch." - (match discrepancy - (($ <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) + verbose?) + "Write to the current error port a summary of REPORT, a <comparison-report> +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 + (($ <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)) - - (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-hashes item local narinfos)) + (($ <comparison-report> item 'inconclusive #f narinfos) + (warning (_ "could not challenge '~a': no local build~%") item)) + (($ <comparison-report> item 'inconclusive locals ()) + (warning (_ "could not challenge '~a': no substitutes~%") item)) + (($ <comparison-report> item 'match local (narinfos ...)) + (when verbose? + (report (_ "~a contents match:~%") item) + (report-hashes item local narinfos))))) ;;; @@ -178,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")) @@ -201,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 @@ -220,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 @@ -236,13 +287,15 @@ 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 (cut summarize-report <> #:verbose? verbose?) + 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/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 <davet@gnu.org> -;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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/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 <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -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) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 79622ac149..6be9d00aec 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -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/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 0d2e7089aa..59ade0a8c1 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 <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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,17 +41,23 @@ (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 #:optional output) + "Perform the download described by DRV, a fixed-output derivation, to +OUTPUT. + +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") + (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))) @@ -91,20 +97,25 @@ 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 <http://bugs.gnu.org/22774>." + + ;; 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)) - ;; 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'.) + (((? derivation-path? drv) (? store-path? output)) + (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 - (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) |