diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 55 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 148 | ||||
| -rw-r--r-- | guix/scripts/challenge.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 23 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/edit.scm | 29 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/opam.scm | 27 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 77 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 367 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 139 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 44 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 260 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 174 |
18 files changed, 926 insertions, 479 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index fb2f61ce30..950f0f41d8 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, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) @@ -55,7 +56,11 @@ (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (verbosity . 0))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (verbosity . 2) + (debug . 0))) (define (show-help) (display (G_ "Usage: guix archive [OPTION]... PACKAGE... @@ -85,6 +90,8 @@ Export/import one or more packages from/to the store.\n")) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) @@ -161,6 +168,11 @@ Export/import one or more packages from/to the store.\n")) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) @@ -239,7 +251,6 @@ build and a list of store files to transfer." resulting archive to the standard output port." (let-values (((drv files) (options->derivations+files store opts))) - (set-build-options-from-command-line store opts) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) #:dry-run? (assoc-ref opts 'dry-run?)) @@ -329,21 +340,23 @@ the input port." ((assoc-ref opts 'authorize) (authorize-key)) (else - (with-store store - (cond ((assoc-ref opts 'export) - (export-from-store store opts)) - ((assoc-ref opts 'import) - (import-paths store (current-input-port))) - ((assoc-ref opts 'missing) - (let* ((files (lines (current-input-port))) - (missing (remove (cut valid-path? store <>) - files))) - (format #t "~{~a~%~}" missing))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (G_ "either '--export' or '--import' \ -must be specified~%")))))))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) + (else + (leave + (G_ "either '--export' or '--import' \ +must be specified~%"))))))))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 0b7da3189e..5a158799ae 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, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -450,13 +450,13 @@ options handled by 'set-build-options-from-command-line', and listed in (display (G_ " --timeout=SECONDS mark the build as failed after SECONDS of activity")) (display (G_ " - --verbosity=LEVEL use the given verbosity LEVEL")) - (display (G_ " --rounds=N build N times in a row to detect non-determinism")) (display (G_ " -c, --cores=N allow the use of up to N CPU cores for the build")) (display (G_ " - -M, --max-jobs=N allow at most N build jobs"))) + -M, --max-jobs=N allow at most N build jobs")) + (display (G_ " + --debug=LEVEL produce debugging output at LEVEL"))) (define (set-build-options-from-command-line store opts) "Given OPTS, an alist as returned by 'args-fold' given @@ -479,7 +479,7 @@ options handled by 'set-build-options-from-command-line', and listed in (assoc-ref opts 'print-extended-build-trace?) #:multiplexed-build-output? (assoc-ref opts 'multiplexed-build-output?) - #:verbosity (assoc-ref opts 'verbosity))) + #:verbosity (assoc-ref opts 'debug))) (define set-build-options-from-command-line* (store-lift set-build-options-from-command-line)) @@ -553,12 +553,12 @@ options handled by 'set-build-options-from-command-line', and listed in (apply values (alist-cons 'timeout (string->number* arg) result) rest))) - (option '("verbosity") #t #f + (option '("debug") #t #f (lambda (opt name arg result . rest) - (let ((level (string->number arg))) + (let ((level (string->number* arg))) (apply values - (alist-cons 'verbosity level - (alist-delete 'verbosity result)) + (alist-cons 'debug level + (alist-delete 'debug result)) rest)))) (option '(#\c "cores") #t #f (lambda (opt name arg result . rest) @@ -590,7 +590,8 @@ options handled by 'set-build-options-from-command-line', and listed in (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0))) + (verbosity . 2) + (debug . 0))) (define (show-help) (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... @@ -619,6 +620,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " -q, --quiet do not show the build log")) (display (G_ " --log-file return the log file names for the given derivations")) @@ -694,9 +697,15 @@ must be one of 'package', 'all', or 'transitive'~%") (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\q "quiet") #f #f (lambda (opt name arg result) - (alist-cons 'quiet? #t result))) + (alist-cons 'verbosity 0 + (alist-delete 'verbosity result)))) (option '("log-file") #f #f (lambda (opt name arg result) (alist-cons 'log-file? #t result))) @@ -788,13 +797,15 @@ package '~a' has no source~%") ((? file-like? obj) (list (run-with-store store (lower-object obj system - #:target (assoc-ref opts 'target))))) + #:target (assoc-ref opts 'target)) + #:system system))) ((? gexp? gexp) (list (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) (gexp->derivation "gexp" gexp - #:system system)))))) + #:system system)) + #:system system)))) (map (cut transform store <>) (options->things-to-build opts)))))) @@ -817,66 +828,59 @@ needed." (parse-command-line args %options (list %default-options))) - (define quiet? - (assoc-ref opts 'quiet?)) - (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (with-store store - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) - - (parameterize ((current-terminal-columns (terminal-columns)) - (current-build-output-port - (if quiet? - (%make-void-port "w") - (build-event-output-port - (build-status-updater print-build-event))))) - (let* ((mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - file) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - - (unless (or (assoc-ref opts 'log-file?) - (assoc-ref opts 'derivations-only?)) - (show-what-to-build store drv - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation-file-name drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + + (parameterize ((current-terminal-columns (terminal-columns))) + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (unless (or (assoc-ref opts 'log-file?) + (assoc-ref opts 'derivations-only?)) + (show-what-to-build store drv + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) + + (cond ((assoc-ref opts 'log-file?) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation-file-name drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots))))))))))) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index f0693ed8df..65de42053d 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -109,7 +109,7 @@ "Return the hash of ITEM, a store item, if ITEM was built locally. Otherwise return #f." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (values #f store))) (if (locally-built? store item) (values (query-path-hash store item) store) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 4c85929858..be4ce4364b 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix scripts) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix utils) #:use-module (guix derivations) #:use-module (guix scripts build) @@ -116,6 +117,8 @@ Copy ITEMS to or from the specified host over SSH.\n")) --to=HOST send ITEMS to HOST")) (display (G_ " --from=HOST receive ITEMS from HOST")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) (newline) @@ -134,6 +137,11 @@ Copy ITEMS to or from the specified host over SSH.\n")) (option '("from") #t #f (lambda (opt name arg result) (alist-cons 'source arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -152,7 +160,11 @@ Copy ITEMS to or from the specified host over SSH.\n")) (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (verbosity . 0))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (debug . 0) + (verbosity . 2))) ;;; @@ -164,6 +176,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (let* ((opts (parse-command-line args %options (list %default-options))) (source (assoc-ref opts 'source)) (target (assoc-ref opts 'destination))) - (cond (target (send-to-remote-host target opts)) - (source (retrieve-from-remote-host source opts)) - (else (leave (G_ "use '--to' or '--from'~%"))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (cond (target (send-to-remote-host target opts)) + (source (retrieve-from-remote-host source opts)) + (else (leave (G_ "use '--to' or '--from'~%")))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index b9162d3449..d8fe71ce12 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -77,7 +77,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (format #t (G_ " --no-check-certificate do not validate the certificate of HTTPS servers ")) - (format #f (G_ " + (format #t (G_ " -o, --output=FILE download to FILE")) (newline) (display (G_ " diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 8b2b61d76a..da3d2775e8 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -21,7 +21,6 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix utils) - #:use-module (guix packages) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) @@ -63,14 +62,13 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) file path)) absolute-file-name)) -(define (package->location-specification package) - "Return the location specification for PACKAGE for a typical editor command +(define (location->location-specification location) + "Return the location specification for LOCATION for a typical editor command line." - (let ((loc (package-location package))) - (list (string-append "+" - (number->string - (location-line loc))) - (search-path* %load-path (location-file loc))))) + (list (string-append "+" + (number->string + (location-line location))) + (search-path* %load-path (location-file location)))) (define (guix-edit . args) @@ -83,18 +81,13 @@ line." '())) (with-error-handling - (let* ((specs (reverse (parse-arguments))) - (packages (map specification->package specs))) - (for-each (lambda (package) - (unless (package-location package) - (leave (G_ "source location of package '~a' is unknown~%") - (package-full-name package)))) - packages) + (let* ((specs (reverse (parse-arguments))) + (locations (map specification->location specs))) (catch 'system-error (lambda () - (let ((file-names (append-map package->location-specification - packages))) + (let ((file-names (append-map location->location-specification + locations))) ;; Use `system' instead of `exec' in order to sanely handle ;; possible command line arguments in %EDITOR. (exit (system (string-join (cons (%editor) file-names)))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 86e1eb115f..116b8dcbce 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, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -158,6 +158,8 @@ COMMAND or an interactive shell in that environment.\n")) --expose=SPEC for containers, expose read-only host file system according to SPEC")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " --bootstrap use bootstrap binaries to build the environment")) (newline) (show-build-options-help) @@ -179,7 +181,8 @@ COMMAND or an interactive shell in that environment.\n")) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0))) + (debug . 0) + (verbosity . 2))) (define (tag-package-arg opts arg) "Return a two-element list with the form (TAG ARG) that tags ARG with either @@ -260,6 +263,11 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -674,7 +682,7 @@ message if any test fails." (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store - (with-status-report print-build-event + (with-status-verbosity (assoc-ref opts 'verbosity) (define manifest (options/resolve-packages store opts)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 145a574dba..8efeef3274 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -299,7 +299,7 @@ this type of graph"))))))) information available in the local store or using information about substitutes." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (match (substitutable-path-info store (list item)) ((info) (values (substitutable-references info) store)) diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm index b549878742..2d249a213f 100644 --- a/guix/scripts/import/opam.scm +++ b/guix/scripts/import/opam.scm @@ -25,6 +25,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-opam)) @@ -43,6 +44,8 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -56,6 +59,9 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import opam"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -81,11 +87,22 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (opam->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (opam-recursive-import package-name)))) + ;; Single import + (let ((sexp (opam->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 2314f3b28c..ddad5b7fd0 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,13 +1,14 @@ ;;; 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, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 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> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,8 +45,10 @@ #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) + #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (ice-9 format) + #:use-module (web client) #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors @@ -73,7 +76,9 @@ check-home-page check-source check-source-file-name + check-source-unstable-tarball check-mirror-url + check-github-url check-license check-vulnerabilities check-for-updates @@ -590,7 +595,8 @@ from ~a") 'home-page))))) (define %distro-directory - (dirname (search-path %load-path "gnu.scm"))) + (mlambda () + (dirname (search-path %load-path "gnu.scm")))) (define (check-patch-file-names package) "Emit a warning if the patches requires by PACKAGE are badly named or if the @@ -615,12 +621,12 @@ patch could not be found." 'patch-file-names)) ;; Check whether we're reaching tar's maximum file name length. - (let ((prefix (string-length %distro-directory)) + (let ((prefix (string-length (%distro-directory))) (margin (string-length "guix-0.13.0-10-123456789/")) (max 99)) (for-each (match-lambda ((? string? patch) - (when (> (+ margin (if (string-prefix? %distro-directory + (when (> (+ margin (if (string-prefix? (%distro-directory) patch) (- (string-length patch) prefix) (string-length patch))) @@ -748,6 +754,23 @@ descriptions maintained upstream." (G_ "the source file name should contain the package name") 'source)))) +(define (check-source-unstable-tarball package) + "Emit a warning if PACKAGE's source is an autogenerated tarball." + (define (check-source-uri uri) + (when (and (string=? (uri-host (string->uri uri)) "github.com") + (match (split-and-decode-uri-path + (uri-path (string->uri uri))) + ((_ _ "archive" _ ...) #t) + (_ #f))) + (emit-warning package + (G_ "the source URI should not be an autogenerated tarball") + 'source))) + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (for-each check-source-uri uris))))) + (define (check-mirror-url package) "Check whether PACKAGE uses source URLs that should be 'mirror://'." (define (check-mirror-uri uri) ;XXX: could be optimized @@ -773,16 +796,48 @@ descriptions maintained upstream." (let ((uris (origin-uris origin))) (for-each check-mirror-uri uris))))) +(define (check-github-url package) + "Check whether PACKAGE uses source URLs that redirect to GitHub." + (define (follow-redirect uri) + (receive (response body) (http-head uri) + (case (response-code response) + ((301 302) + (uri->string (assoc-ref (response-headers response) 'location))) + (else #f)))) + + (define (follow-redirects-to-github uri) + (cond + ((string-prefix? "https://github.com/" uri) uri) + ((string-prefix? "http" uri) + (and=> (follow-redirect uri) follow-redirects-to-github)) + ;; Do not attempt to follow redirects on URIs other than http and https + ;; (such as mirror, file) + (else #f))) + + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (for-each + (lambda (uri) + (and=> (follow-redirects-to-github uri) + (lambda (github-uri) + (unless (string=? github-uri uri) + (emit-warning + package + (format #f (G_ "URL should be '~a'") github-uri) + 'source))))) + (origin-uris origin))))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try system) (catch #t (lambda () - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") system - (nix-protocol-error-message c)))) + (store-protocol-error-message c)))) ((message-condition? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") @@ -1056,10 +1111,18 @@ or a list thereof") (description "Suggest 'mirror://' URLs") (check check-mirror-url)) (lint-checker + (name 'github-url) + (description "Suggest GitHub URLs") + (check check-github-url)) + (lint-checker (name 'source-file-name) (description "Validate file names of sources") (check check-source-file-name)) (lint-checker + (name 'source-unstable-tarball) + (description "Check for autogenerated tarballs") + (check check-source-unstable-tarball)) + (lint-checker (name 'derivation) (description "Report failure to compile a package to a derivation") (check check-derivation)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index ee5857e16b..eb02672dbf 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -23,13 +23,12 @@ #:use-module (ssh session) #:use-module (ssh channel) #:use-module (ssh popen) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix derivations) #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) @@ -261,13 +260,6 @@ instead of '~a' of type '~a'~%") (lambda () (unlock-file port))))) -(define-syntax-rule (with-machine-lock machine hint exp ...) - "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that -context." - (with-file-lock (machine-lock-file machine hint) - exp ...)) - - (define (machine-slot-file machine slot) "Return the file name of MACHINE's file for SLOT." ;; For each machine we have a bunch of files representing each build slot. @@ -285,23 +277,25 @@ the slot, or #f if none is available. This mechanism allows us to set a hard limit on the number of simultaneous connections allowed to MACHINE." (mkdir-p (dirname (machine-slot-file machine 0))) - (with-machine-lock machine 'slots - (any (lambda (slot) - (let ((port (open-file (machine-slot-file machine slot) - "w0"))) - (catch 'flock-error - (lambda () - (fcntl-flock port 'write-lock #:wait? #f) - ;; Got it! - (format (current-error-port) - "process ~a acquired build slot '~a'~%" - (getpid) (port-filename port)) - port) - (lambda args - ;; PORT is already locked by another process. - (close-port port) - #f)))) - (iota (build-machine-parallel-builds machine))))) + + ;; When several 'guix offload' processes run in parallel, there's a race + ;; among them, but since they try the slots in the same order, we're fine. + (any (lambda (slot) + (let ((port (open-file (machine-slot-file machine slot) + "w0"))) + (catch 'flock-error + (lambda () + (fcntl-flock port 'write-lock #:wait? #f) + ;; Got it! + (format (current-error-port) + "process ~a acquired build slot '~a'~%" + (getpid) (port-filename port)) + port) + (lambda args + ;; PORT is already locked by another process. + (close-port port) + #f)))) + (iota (build-machine-parallel-builds machine)))) (define (release-build-slot slot) "Release SLOT, a build slot as returned as by 'acquire-build-slot'." @@ -321,6 +315,16 @@ hook." (set-port-revealed! port 1) port)) +(define (node-guile-version node) + (inferior-eval '(version) node)) + +(define (node-free-disk-space node) + "Return the free disk space, in bytes, in NODE's store." + (inferior-eval `(begin + (use-modules (guix build syscalls)) + (free-disk-space ,(%store-prefix))) + node)) + (define* (transfer-and-offload drv machine #:key (inputs '()) @@ -354,15 +358,29 @@ MACHINE." (format (current-error-port) "@ build-remote ~a ~a~%" (derivation-file-name drv) (build-machine-name machine)) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (format (current-error-port) (G_ "derivation '~a' offloaded to '~a' failed: ~a~%") (derivation-file-name drv) (build-machine-name machine) - (nix-protocol-error-message c)) - ;; Use exit code 100 for a permanent build failure. The daemon - ;; interprets other non-zero codes as transient build failures. - (primitive-exit 100))) + (store-protocol-error-message c)) + (let* ((inferior (false-if-exception (remote-inferior session))) + (space (false-if-exception + (node-free-disk-space inferior)))) + + (when inferior + (close-inferior inferior)) + + ;; Use exit code 100 for a permanent build failure. The daemon + ;; interprets other non-zero codes as transient build failures. + (if (and space (< space (* 10 (expt 2 20)))) + (begin + (format (current-error-port) + (G_ "build failure may have been caused by lack \ +of free disk space on '~a'~%") + (build-machine-name machine)) + (primitive-exit 1)) + (primitive-exit 100))))) (parameterize ((current-build-output-port (build-log-port))) (build-derivations store (list drv)))) @@ -392,43 +410,37 @@ MACHINE." (build-requirements-features requirements) (build-machine-features machine)))) -(define (machine-load machine) - "Return the load of MACHINE, divided by the number of parallel builds -allowed on MACHINE. Return +∞ if MACHINE is unreachable." - ;; Note: This procedure is costly since it creates a new SSH session. - (match (false-if-exception (open-ssh-session machine)) - ((? session? session) - (let* ((pipe (open-remote-pipe* session OPEN_READ - "cat" "/proc/loadavg")) - (line (read-line pipe))) - (close-port pipe) - (disconnect! session) - - (if (eof-object? line) - +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded - (match (string-tokenize line) - ((one five fifteen . x) - (let* ((raw (string->number one)) - (jobs (build-machine-parallel-builds machine)) - (normalized (/ raw jobs))) - (format (current-error-port) "load on machine '~a' is ~s\ +(define %minimum-disk-space + ;; Minimum disk space required on the build machine for a build to be + ;; offloaded. This keeps us from offloading to machines that are bound to + ;; run out of disk space. + (* 100 (expt 2 20))) ;100 MiB + +(define (node-load node) + "Return the load on NODE. Return +∞ if NODE is misbehaving." + (let ((line (inferior-eval '(begin + (use-modules (ice-9 rdelim)) + (call-with-input-file "/proc/loadavg" + read-string)) + node))) + (if (eof-object? line) + +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded + (match (string-tokenize line) + ((one five fifteen . x) + (string->number one)) + (x + +inf.0))))) + +(define (normalized-load machine load) + "Divide LOAD by the number of parallel builds of MACHINE." + (if (rational? load) + (let* ((jobs (build-machine-parallel-builds machine)) + (normalized (/ load jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ (normalized: ~s)~%" - (build-machine-name machine) raw normalized) - normalized)) - (x - +inf.0))))) ;something's fishy about MACHINE, so avoid it - (x - +inf.0))) ;failed to connect to MACHINE, so avoid it - -(define (machine-lock-file machine hint) - "Return the name of MACHINE's lock file for HINT." - (string-append %state-directory "/offload/" - (build-machine-name machine) - "." (symbol->string hint) ".lock")) - -(define (machine-choice-lock-file) - "Return the name of the file used as a lock when choosing a build machine." - (string-append %state-directory "/offload/machine-choice.lock")) + (build-machine-name machine) load normalized) + normalized) + load)) (define (random-seed) (logxor (getpid) (car (gettimeofday)))) @@ -452,41 +464,44 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." slot (which must later be released with 'release-build-slot'), or #f and #f." ;; Proceed like this: - ;; 1. Acquire the global machine-choice lock. - ;; 2. For all MACHINES, attempt to acquire a build slot, and filter out + ;; 1. For all MACHINES, attempt to acquire a build slot, and filter out ;; those machines for which we failed. - ;; 3. Choose the best machine among those that are left. - ;; 4. Release the previously-acquired build slots of the other machines. - ;; 5. Release the global machine-choice lock. - - (with-file-lock (machine-choice-lock-file) - (define machines+slots - (filter-map (lambda (machine) - (let ((slot (acquire-build-slot machine))) - (and slot (list machine slot)))) - (shuffle machines))) - - (define (undecorate pred) - (lambda (a b) - (match a - ((machine1 slot1) - (match b - ((machine2 slot2) - (pred machine1 machine2))))))) - - (define (machine-faster? m1 m2) - ;; Return #t if M1 is faster than M2. - (> (build-machine-speed m1) - (build-machine-speed m2))) - - (let loop ((machines+slots - (sort machines+slots (undecorate machine-faster?)))) - (match machines+slots - (((best slot) others ...) - ;; Return the best machine unless it's already overloaded. - ;; Note: We call 'machine-load' only as a last resort because it is - ;; too costly to call it once for every machine. - (if (< (machine-load best) 2.) + ;; 2. Choose the best machine among those that are left. + ;; 3. Release the previously-acquired build slots of the other machines. + + (define machines+slots + (filter-map (lambda (machine) + (let ((slot (acquire-build-slot machine))) + (and slot (list machine slot)))) + (shuffle machines))) + + (define (undecorate pred) + (lambda (a b) + (match a + ((machine1 slot1) + (match b + ((machine2 slot2) + (pred machine1 machine2))))))) + + (define (machine-faster? m1 m2) + ;; Return #t if M1 is faster than M2. + (> (build-machine-speed m1) + (build-machine-speed m2))) + + (let loop ((machines+slots + (sort machines+slots (undecorate machine-faster?)))) + (match machines+slots + (((best slot) others ...) + ;; Return the best machine unless it's already overloaded. + ;; Note: We call 'node-load' only as a last resort because it is + ;; too costly to call it once for every machine. + (let* ((session (false-if-exception (open-ssh-session best))) + (node (and session (remote-inferior session))) + (load (and node (normalized-load best (node-load node)))) + (space (and node (node-free-disk-space node)))) + (when node (close-inferior node)) + (when session (disconnect! session)) + (if (and node (< load 2.) (>= space %minimum-disk-space)) (match others (((machines slots) ...) ;; Release slots from the uninteresting machines. @@ -496,11 +511,17 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; eventually release it. (values best slot))) (begin - ;; BEST is overloaded, so try the next one. + ;; BEST is unsuitable, so try the next one. + (when (and space (< space %minimum-disk-space)) + (format (current-error-port) + "skipping machine '~a' because it is low \ +on disk space (~,2f MiB free)~%" + (build-machine-name best) + (/ space (expt 2 20) 1.))) (release-build-slot slot) - (loop others)))) - (() - (values #f #f)))))) + (loop others))))) + (() + (values #f #f))))) (define (call-with-timeout timeout drv thunk) "Call THUNK and leave after TIMEOUT seconds. If TIMEOUT is #f, simply call @@ -581,40 +602,34 @@ If TIMEOUT is #f, simply evaluate EXP..." (#f (report-guile-error name)) ((? string? version) - ;; Note: The version string already contains the word "Guile". - (info (G_ "'~a' is running ~a~%") + (info (G_ "'~a' is running GNU Guile ~a~%") name (node-guile-version node))))) (define (assert-node-has-guix node name) - "Bail out if NODE lacks the (guix) module, or if its daemon is not running." - (catch 'node-repl-error - (lambda () - (match (node-eval node - '(begin + "Bail out if NODE if #f or if we fail to use the (guix) module, or if its +daemon is not running." + (unless (inferior? node) + (leave (G_ "failed to run 'guix repl' on '~a'~%") name)) + + (match (inferior-eval '(begin (use-modules (guix)) - (and add-text-to-store 'alright))) - ('alright #t) - (_ (report-module-error name)))) - (lambda (key . args) - (report-module-error name))) + (and add-text-to-store 'alright)) + node) + ('alright #t) + (_ (report-module-error name))) - (catch 'node-repl-error - (lambda () - (match (node-eval node - '(begin + (match (inferior-eval '(begin (use-modules (guix)) (with-store store (add-text-to-store store "test" - "Hello, build machine!")))) - ((? string? str) - (info (G_ "Guix is usable on '~a' (test returned ~s)~%") - name str)) - (x - (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") - name x)))) - (lambda (key . args) - (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%") - name args)))) + "Hello, build machine!"))) + node) + ((? string? str) + (info (G_ "Guix is usable on '~a' (test returned ~s)~%") + name str)) + (x + (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") + name x)))) (define %random-state (delay @@ -624,25 +639,23 @@ If TIMEOUT is #f, simply evaluate EXP..." (string-append name "-" (number->string (random 1000000 (force %random-state))))) -(define (assert-node-can-import node name daemon-socket) +(define (assert-node-can-import session node name daemon-socket) "Bail out if NODE refuses to import our archives." - (let ((session (node-session node))) - (with-store store - (let* ((item (add-text-to-store store "export-test" (nonce))) - (remote (connect-to-remote-daemon session daemon-socket))) - (with-store local - (send-files local (list item) remote)) - - (if (valid-path? remote item) - (info (G_ "'~a' successfully imported '~a'~%") - name item) - (leave (G_ "'~a' was not properly imported on '~a'~%") - item name)))))) - -(define (assert-node-can-export node name daemon-socket) + (with-store store + (let* ((item (add-text-to-store store "export-test" (nonce))) + (remote (connect-to-remote-daemon session daemon-socket))) + (with-store local + (send-files local (list item) remote)) + + (if (valid-path? remote item) + (info (G_ "'~a' successfully imported '~a'~%") + name item) + (leave (G_ "'~a' was not properly imported on '~a'~%") + item name))))) + +(define (assert-node-can-export session node name daemon-socket) "Bail out if we cannot import signed archives from NODE." - (let* ((session (node-session node)) - (remote (connect-to-remote-daemon session daemon-socket)) + (let* ((remote (connect-to-remote-daemon session daemon-socket)) (item (add-text-to-store remote "import-test" (nonce name)))) (with-store store (if (and (retrieve-files store (list item) remote) @@ -669,11 +682,13 @@ machine." (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) (sessions (map open-ssh-session machines)) - (nodes (map make-node sessions))) - (for-each assert-node-repl nodes names) + (nodes (map remote-inferior sessions))) (for-each assert-node-has-guix nodes names) - (for-each assert-node-can-import nodes names sockets) - (for-each assert-node-can-export nodes names sockets)))) + (for-each assert-node-repl nodes names) + (for-each assert-node-can-import sessions nodes names sockets) + (for-each assert-node-can-export sessions nodes names sockets) + (for-each close-inferior nodes) + (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) "Print the load of each machine matching PRED in MACHINE-FILE." @@ -689,16 +704,41 @@ machine." (info (G_ "getting status of ~a build machines defined in '~a'...~%") (length machines) machine-file) (for-each (lambda (machine) - (let* ((node (make-node (open-ssh-session machine))) - (uts (node-eval node '(uname)))) - (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ - host name: ~a~% normalized load: ~a~%" - (build-machine-name machine) - (utsname:sysname uts) (utsname:release uts) - (utsname:machine uts) - (utsname:nodename uts) - (parameterize ((current-error-port (%make-void-port "rw+"))) - (machine-load machine))))) + (define session + (open-ssh-session machine)) + + (match (remote-inferior session) + (#f + (warning (G_ "failed to run 'guix repl' on machine '~a'~%") + (build-machine-name machine))) + ((? inferior? inferior) + (let ((now (car (gettimeofday)))) + (match (inferior-eval '(list (uname) + (car (gettimeofday))) + inferior) + ((uts time) + (when (< time now) + ;; Build machine clocks must not be behind as this + ;; could cause timestamp issues. + (warning (G_ "machine '~a' is ~a seconds behind~%") + (build-machine-name machine) + (- now time))) + + (let ((load (node-load inferior)) + (free (node-free-disk-space inferior))) + (close-inferior inferior) + (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ + host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%\ + time difference: ~a s~%" + (build-machine-name machine) + (utsname:sysname uts) (utsname:release uts) + (utsname:machine uts) + (utsname:nodename uts) + (normalized-load machine load) + (/ free (expt 2 20) 1.) + (- time now)))))))) + + (disconnect! session)) machines))) @@ -789,7 +829,6 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) (leave (G_ "invalid arguments: ~{~s ~}~%") x)))) ;;; Local Variables: -;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) ;;; eval: (put 'with-file-lock 'scheme-indent-function 1) ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 2) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6c6680ab58..40e59a6101 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> @@ -553,9 +553,7 @@ please email '~a'~%") "run.c" "-o" result) (delete-file "run.c"))) - (setvbuf (current-output-port) - (cond-expand (guile-2.2 'line) - (else _IOLBF))) + (setvbuf (current-output-port) 'line) ;; Link the top-level files of PACKAGE so that search paths are ;; properly defined in PROFILE/etc/profile. @@ -600,7 +598,8 @@ please email '~a'~%") (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0) + (debug . 0) + (verbosity . 2) (symlinks . ()) (compressor . ,(first %compressors)))) @@ -687,6 +686,11 @@ please email '~a'~%") (alist-cons 'profile-name arg result)) (_ (leave (G_ "~a: unsupported profile name~%") arg))))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -725,6 +729,8 @@ Create a bundle of PACKAGE.\n")) --profile-name=NAME populate /var/guix/profiles/.../NAME")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) (newline) (display (G_ " @@ -774,7 +780,7 @@ Create a bundle of PACKAGE.\n")) (with-error-handling (with-store store - (with-status-report print-build-event + (with-status-verbosity (assoc-ref opts 'verbosity) ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5743816324..8a71467b52 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, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -120,21 +120,21 @@ denote ranges as interpreted by 'matching-generations'." (define* (build-and-use-profile store profile manifest #:key + (hooks %default-profile-hooks) allow-collisions? bootstrap? use-substitutes? dry-run?) "Build a new generation of PROFILE, a file name, using the packages specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true, -do not treat collisions in MANIFEST as an error." +do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile +hooks\" run when building the profile." (when (equal? profile %current-profile) (ensure-default-profile)) (let* ((prof-drv (run-with-store store (profile-derivation manifest #:allow-collisions? allow-collisions? - #:hooks (if bootstrap? - '() - %default-profile-hooks) + #:hooks (if bootstrap? '() hooks) #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-what-to-build store (list prof-drv) @@ -220,31 +220,32 @@ of relevance scores." ('dismiss transaction) (($ <manifest-entry> name version output (? string? path)) - (match (vhash-assoc name (find-newest-available-packages)) - ((_ candidate-version pkg . rest) - (match (package-superseded pkg) - ((? package? new) - (supersede entry new)) - (#f - (case (version-compare candidate-version version) - ((>) - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)) - ((<) - transaction) - ((=) - (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) - ;; XXX: When there are propagated inputs, assume we need to - ;; upgrade the whole entry. - (if (and (string=? path candidate-path) - (null? (package-propagated-inputs pkg))) - transaction - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)))))))) - (#f + (match (find-best-packages-by-name name #f) + ((pkg . rest) + (let ((candidate-version (package-version pkg))) + (match (package-superseded pkg) + ((? package? new) + (supersede entry new)) + (#f + (case (version-compare candidate-version version) + ((>) + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction)) + ((<) + transaction) + ((=) + (let ((candidate-path (derivation->output-path + (package-derivation (%store) pkg)))) + ;; XXX: When there are propagated inputs, assume we need to + ;; upgrade the whole entry. + (if (and (string=? path candidate-path) + (null? (package-propagated-inputs pkg))) + transaction + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction))))))))) + (() (warning (G_ "package '~a' no longer exists~%") name) transaction))))) @@ -293,7 +294,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (define %default-options ;; Alist of default option values. - `((verbosity . 0) + `((verbosity . 1) + (debug . 0) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -346,7 +348,7 @@ Install, remove, or upgrade packages in a single transaction.\n")) (display (G_ " --bootstrap use the bootstrap Guile to build the profile")) (display (G_ " - --verbose produce verbose output")) + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " -s, --search=REGEXP search in synopsis and description using REGEXP")) @@ -472,13 +474,21 @@ kind of search path~%") (values (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)) #f))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result arg-handler) + (let ((level (string->number* arg))) + (values (alist-cons 'verbosity level + (alist-delete 'verbosity result)) + #f)))) (option '("bootstrap") #f #f (lambda (opt name arg result arg-handler) (values (alist-cons 'bootstrap? #t result) #f))) - (option '("verbose") #f #f + (option '("verbose") #f #f ;deprecated (lambda (opt name arg result arg-handler) - (values (alist-cons 'verbose? #t result) + (values (alist-cons 'verbosity 2 + (alist-delete 'verbosity + result)) #f))) (option '("allow-collisions") #f #f (lambda (opt name arg result arg-handler) @@ -595,12 +605,12 @@ and upgrades." (options->upgrade-predicate opts)) (define upgraded - (fold-right (lambda (entry transaction) - (if (upgrade? (manifest-entry-name entry)) - (transaction-upgrade-entry entry transaction) - transaction)) - transaction - (manifest-entries manifest))) + (fold (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda @@ -726,29 +736,34 @@ processed, #f otherwise." (('list-available regexp) (let* ((regexp (and regexp (make-regexp* regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if (and (supported-package? p) - (not (package-superseded p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)) - r))) + (available (fold-available-packages + (lambda* (name version result + #:key outputs location + supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (if regexp + (if (regexp-exec regexp name) + (cons `(,name ,version + ,outputs ,location) + result) + result) + (cons `(,name ,version + ,outputs ,location) + result)) + result)) '()))) (leave-on-EPIPE - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) + (for-each (match-lambda + ((name version outputs location) + (format #t "~a\t~a\t~a\t~a~%" + name version + (string-join outputs ",") + (location->string location)))) (sort available - (lambda (p1 p2) - (string<? (package-name p1) - (package-name p2)))))) + (match-lambda* + (((name1 . _) (name2 . _)) + (string<? name1 name2)))))) #t)) (('search _) @@ -907,14 +922,12 @@ processed, #f otherwise." (define opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument)) - (define verbose? - (assoc-ref opts 'verbose?)) (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection)) (%graft? (assoc-ref opts 'graft?))) - (with-status-report print-build-event/quiet + (with-status-verbosity (assoc-ref opts 'verbosity) (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index dc83729911..683ab3f059 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. @@ -34,17 +34,19 @@ #:use-module (guix channels) #:autoload (guix inferior) (open-inferior) #:use-module (guix scripts build) + #:autoload (guix build utils) (which) #:use-module (guix git) #:use-module (git) #:use-module (gnu packages) #:use-module ((guix scripts package) #:select (build-and-use-profile)) - #:use-module (gnu packages base) + #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) @@ -66,7 +68,8 @@ (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) - (verbosity . 0))) + (debug . 0) + (verbosity . 1))) (define (show-help) (display (G_ "Usage: guix pull [OPTION]... @@ -89,6 +92,10 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " -n, --dry-run show what would be pulled and built")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) (show-build-options-help) @@ -120,15 +127,23 @@ Download and deploy the latest version of Guix.\n")) (alist-cons 'ref `(commit . ,arg) result))) (option '("branch") #t #f (lambda (opt name arg result) - (alist-cons 'ref `(branch . ,(string-append "origin/" arg)) - result))) + (alist-cons 'ref `(branch . ,arg) result))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -175,9 +190,21 @@ true, display what would be built without actually building it." (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad (update-profile profile manifest + #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? - (return (display-profile-news profile)))))) + (return (display-profile-news profile)) + (match (which "guix") + (#f (return #f)) + (str + (let ((new (map (cut string-append <> "/bin/guix") + (list (user-friendly-profile profile) + profile)))) + (unless (member str new) + (display-hint (format #f (G_ "After setting @code{PATH}, run +@command{hash guix} to make sure your shell refers to @file{~a}.") + (first new)))) + (return #f)))))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -504,8 +531,9 @@ Use '~/.config/guix/channels.scm' instead.")) (process-query opts profile)) (else (with-store store - (with-status-report print-build-event - (parameterize ((%graft? (assoc-ref opts 'graft?)) + (with-status-verbosity (assoc-ref opts 'verbosity) + (parameterize ((%current-system (assoc-ref opts 'system)) + (%graft? (assoc-ref opts 'graft?)) (%repository-cache-directory cache)) (set-build-options-from-command-line store opts) (honor-x509-certificates store) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 1d86f949c8..5b0f345cde 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,10 +1,12 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -88,6 +90,12 @@ (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) + (option '("list-transitive") #f #f + (lambda (opt name arg result) + (alist-cons 'list-transitive? #t result))) (option '("keyring") #t #f (lambda (opt name arg result) @@ -140,6 +148,10 @@ specified with `--select'.\n")) (display (G_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) + (display (G_ " + -r, --recursive check the PACKAGE and its inputs for upgrades")) + (display (G_ " + --list-transitive list all the packages that PACKAGE depends on")) (newline) (display (G_ " --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) @@ -160,6 +172,79 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) +(define (options->packages opts) + "Return the list of packages requested by OPTS, honoring options like +'--recursive'." + (define core-package? + (let* ((input->package (match-lambda + ((name (? package? package) _ ...) package) + (_ #f))) + (final-inputs (map input->package %final-inputs)) + (core (append final-inputs + (append-map (compose (cut filter-map input->package <>) + package-transitive-inputs) + final-inputs))) + (names (delete-duplicates (map package-name core)))) + (lambda (package) + "Return true if PACKAGE is likely a \"core package\"---i.e., one whose +update would trigger a complete rebuild." + ;; Compare by name because packages in base.scm basically inherit + ;; other packages. So, even if those packages are not core packages + ;; themselves, updating them would also update those who inherit from + ;; them. + ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. + (member (package-name package) names)))) + + (define (keep-newest package lst) + ;; If a newer version of PACKAGE is already in LST, return LST; otherwise + ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. + (let ((name (package-name package))) + (match (find (lambda (p) + (string=? (package-name p) name)) + lst) + ((? package? other) + (if (version>? (package-version other) (package-version package)) + lst + (cons package (delq other lst)))) + (_ + (cons package lst))))) + + (define args-packages + ;; Packages explicitly passed as command-line arguments. + (match (filter-map (match-lambda + (('argument . spec) + ;; Take either the specified version or the + ;; latest one. + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) + (_ #f)) + opts) + (() ;default to all packages + (let ((select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '()))) + (some ;user-specified packages + some))) + + (define packages + (match (assoc-ref opts 'manifest) + (#f args-packages) + ((? string? file) (packages-from-manifest file)))) + + (if (assoc-ref opts 'recursive?) + (mlet %store-monad ((edges (node-edges %bag-node-type + (all-packages)))) + (return (node-transitive-edges packages edges))) + (with-monad %store-monad + (return packages)))) + ;;; ;;; Updates. @@ -212,7 +297,7 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball) + (let-values (((version tarball changes) (package-update store package updaters #:key-download key-download)) ((loc) @@ -226,6 +311,26 @@ warn about packages that have no matching updater." (location->string loc) (package-name package) (package-version package) version) + (for-each + (lambda (change) + (format (current-error-port) + (match (list (upstream-input-change-action change) + (upstream-input-change-type change)) + (('add 'regular) + (G_ "~a: consider adding this input: ~a~%")) + (('add 'native) + (G_ "~a: consider adding this native input: ~a~%")) + (('add 'propagated) + (G_ "~a: consider adding this propagated input: ~a~%")) + (('remove 'regular) + (G_ "~a: consider removing this input: ~a~%")) + (('remove 'native) + (G_ "~a: consider removing this native input: ~a~%")) + (('remove 'propagated) + (G_ "~a: consider removing this propagated input: ~a~%"))) + (package-name package) + (upstream-input-change-name change))) + (changes)) (let ((hash (call-with-input-file tarball port-sha256))) (update-package-source package version hash))) @@ -295,7 +400,7 @@ the latest known version of ~a (~a)~%") (package-version package))) (mlet %store-monad ((edges (node-back-edges %bag-node-type - (all-packages)))) + (package-closure (all-packages))))) (let* ((dependents (node-transitive-edges packages edges)) (covering (filter (lambda (node) (null? (edges node))) @@ -314,8 +419,8 @@ the latest known version of ~a (~a)~%") (full-name x))) (lst (format (current-output-port) - (N_ "Building the following package would ensure ~d \ -dependent packages are rebuilt: ~*~{~a~^ ~}~%" + (N_ "Building the following ~*package would ensure ~d \ +dependent packages are rebuilt: ~{~a~^ ~}~%" "Building the following ~d packages would ensure ~d \ dependent packages are rebuilt: ~{~a~^ ~}~%" (length covering)) @@ -323,6 +428,30 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (map full-name covering)))) (return #t)))) +(define (list-transitive packages) + "List all the packages that would cause PACKAGES to be rebuilt if they are changed." + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (define (full-name package) + (string-append (package-name package) "@" + (package-version package))) + + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + (match packages + ((x) + (format (current-output-port) + (G_ "~a depends on the following ~d packages: ~{~a~^ ~}~%.") + (full-name x) (length dependent) (map full-name dependent))) + (lst + (format (current-output-port) + (G_ "The following ~d packages \ +all are dependent packages: ~{~a~^ ~}~%") + (length dependent) (map full-name dependent)))) + (return #t)))) + ;;; ;;; Manifest. @@ -365,103 +494,48 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (lists (concatenate lists)))) - (define (keep-newest package lst) - ;; If a newer version of PACKAGE is already in LST, return LST; otherwise - ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. - (let ((name (package-name package))) - (match (find (lambda (p) - (string=? (package-name p) name)) - lst) - ((? package? other) - (if (version>? (package-version other) (package-version package)) - lst - (cons package (delq other lst)))) - (_ - (cons package lst))))) - - (define core-package? - (let* ((input->package (match-lambda - ((name (? package? package) _ ...) package) - (_ #f))) - (final-inputs (map input->package %final-inputs)) - (core (append final-inputs - (append-map (compose (cut filter-map input->package <>) - package-transitive-inputs) - final-inputs))) - (names (delete-duplicates (map package-name core)))) - (lambda (package) - "Return true if PACKAGE is likely a \"core package\"---i.e., one whose -update would trigger a complete rebuild." - ;; Compare by name because packages in base.scm basically inherit - ;; other packages. So, even if those packages are not core packages - ;; themselves, updating them would also update those who inherit from - ;; them. - ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. - (member (package-name package) names)))) - (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) + (recursive? (assoc-ref opts 'recursive?)) (list-dependent? (assoc-ref opts 'list-dependent?)) + (list-transitive? (assoc-ref opts 'list-transitive?)) (key-download (assoc-ref opts 'key-download)) ;; Warn about missing updaters when a package is explicitly given on ;; the command line. - (warn? (or (assoc-ref opts 'argument) - (assoc-ref opts 'expression))) - (args-packages - (match (filter-map (match-lambda - (('argument . spec) - ;; Take either the specified version or the - ;; latest one. - (specification->package spec)) - (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) - opts) - (() ; default to all packages - (let ((select? (match (assoc-ref opts 'select) - ('core core-package?) - ('non-core (negate core-package?)) - (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) - (some ; user-specified packages - some))) - (packages - (match (assoc-ref opts 'manifest) - (#f args-packages) - ((? string? file) (packages-from-manifest file))))) + (warn? (and (or (assoc-ref opts 'argument) + (assoc-ref opts 'expression) + (assoc-ref opts 'manifest)) + (not recursive?)))) (with-error-handling (with-store store (run-with-store store - (cond - (list-dependent? - (list-dependents packages)) - (update? - (parameterize ((%openpgp-key-server - (or (assoc-ref opts 'key-server) - (%openpgp-key-server))) - (%gpg-command - (or (assoc-ref opts 'gpg-command) - (%gpg-command))) - (current-keyring - (or (assoc-ref opts 'keyring) - (string-append (config-directory) - "/upstream/trustedkeys.kbx")))) - (for-each - (cut update-package store <> updaters - #:key-download key-download - #:warn? warn?) - packages) - (with-monad %store-monad - (return #t)))) - (else - (for-each (cut check-for-package-update <> updaters - #:warn? warn?) - packages) - (with-monad %store-monad + (mlet %store-monad ((packages (options->packages opts))) + (cond + (list-dependent? + (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (update? + (parameterize ((%openpgp-key-server + (or (assoc-ref opts 'key-server) + (%openpgp-key-server))) + (%gpg-command + (or (assoc-ref opts 'gpg-command) + (%gpg-command))) + (current-keyring + (or (assoc-ref opts 'keyring) + (string-append (config-directory) + "/upstream/trustedkeys.kbx")))) + (for-each + (cut update-package store <> updaters + #:key-download key-download + #:warn? warn?) + packages) + (return #t))) + (else + (for-each (cut check-for-package-update <> updaters + #:warn? warn?) + packages) (return #t))))))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 53b1777241..797a76db3f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; @@ -219,7 +219,7 @@ provide." (set! port (guix:open-connection-for-uri uri #:verify-certificate? #f)) (unless (or buffered? (not (file-port? port))) - (setvbuf port _IONBF))) + (setvbuf port 'none))) (http-fetch uri #:text? #f #:port port #:verify-certificate? #f)))))) (else @@ -567,7 +567,7 @@ initial connection on which HTTP requests are sent." verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) - (setvbuf p _IOFBF (expt 2 16))) + (setvbuf p 'block (expt 2 16))) ;; Send REQUESTS, up to a certain number, in a row. ;; XXX: Do our own caching to work around inefficiencies when diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 6cda3ccbd6..569b826acd 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -1015,6 +1015,8 @@ Some ACTIONS support additional ARGS.\n")) --full-boot for 'vm', make a full boot sequence")) (display (G_ " --skip-checks skip file system and initrd module safety checks")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -1074,6 +1076,11 @@ Some ACTIONS support additional ARGS.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -1092,7 +1099,8 @@ Some ACTIONS support additional ARGS.\n")) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) - (verbosity . 0) + (debug . 0) + (verbosity . #f) ;default (file-system-type . "ext4") (image-size . guess) (install-bootloader? . #t))) @@ -1267,9 +1275,9 @@ argument list and OPTS is the option alist." (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) - (with-status-report (if (memq command '(init reconfigure)) - print-build-event/quiet - print-build-event) + (with-status-verbosity (or (assoc-ref opts 'verbosity) + (if (memq command '(init reconfigure)) + 1 2)) (process-command command args opts)))))) ;;; Local Variables: diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 98b7338fb9..4b12f9550e 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; @@ -32,6 +32,9 @@ #:use-module (guix scripts substitute) #:use-module (guix http-client) #:use-module (guix ci) + #:use-module (guix sets) + #:use-module (guix graph) + #:autoload (guix scripts graph) (%bag-node-type) #:use-module (gnu packages) #:use-module (web uri) #:use-module (srfi srfi-1) @@ -41,6 +44,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 vlist) #:export (guix-weather)) (define (all-packages) @@ -51,7 +55,10 @@ (cons* replacement package result)) (#f (cons package result)))) - '())) + '() + + ;; Dismiss deprecated packages but keep hidden packages. + #:select? (negate package-superseded))) (define (call-with-progress-reporter reporter proc) "This is a variant of 'call-with-progress-reporter' that works with monadic @@ -254,6 +261,10 @@ Report the availability of substitutes.\n")) -m, --manifest=MANIFEST look up substitutes for packages specified in MANIFEST")) (display (G_ " + -c, --coverage[=COUNT] + show substitute coverage for packages with at least + COUNT dependents")) + (display (G_ " -s, --system=SYSTEM consider substitutes for SYSTEM--e.g., \"i686-linux\"")) (newline) (display (G_ " @@ -286,6 +297,11 @@ Report the availability of substitutes.\n")) (option '(#\m "manifest") #t #f (lambda (opt name arg result) (alist-cons 'manifest arg result))) + (option '(#\c "coverage") #f #t + (lambda (opt name arg result) + (alist-cons 'coverage + (if arg (string->number* arg) 0) + result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg result))))) @@ -302,6 +318,153 @@ Report the availability of substitutes.\n")) ;;; +;;; Missing package substitutes. +;;; + +(define* (package-partition-boundary pred packages + #:key (system (%current-system))) + "Return the subset of PACKAGES that are at the \"boundary\" between those +that match PRED and those that don't. The returned packages themselves do not +match PRED but they have at least one direct dependency that does. + +Note: The assumption is that, if P matches PRED, then all the dependencies of +P match PRED as well." + ;; XXX: Graph theoreticians surely have something to teach us about this... + (let loop ((packages packages) + (result (setq)) + (visited vlist-null)) + (define (visited? package) + (vhash-assq package visited)) + + (match packages + ((package . rest) + (cond ((visited? package) + (loop rest result visited)) + ((pred package) + (loop rest result (vhash-consq package #t visited))) + (else + (let* ((bag (package->bag package system)) + (deps (filter-map (match-lambda + ((label (? package? package) . _) + (and (not (pred package)) + package)) + (_ #f)) + (bag-direct-inputs bag)))) + (loop (append deps rest) + (if (null? deps) + (set-insert package result) + result) + (vhash-consq package #t visited)))))) + (() + (set->list result))))) + +(define (package->output-mapping packages system) + "Return a vhash that maps each item of PACKAGES to its corresponding output +store file names for SYSTEM." + (foldm %store-monad + (lambda (package mapping) + (mlet %store-monad ((drv (package->derivation package system + #:graft? #f))) + (return (vhash-consq package + (match (derivation->output-paths drv) + (((names . outputs) ...) + outputs)) + mapping)))) + vlist-null + packages)) + +(define (substitute-oracle server items) + "Return a procedure that, when passed a store item (one of those listed in +ITEMS), returns true if SERVER has a substitute for it, false otherwise." + (define available + (fold (lambda (narinfo set) + (set-insert (narinfo-path narinfo) set)) + (set) + (lookup-narinfos server items))) + + (cut set-contains? available <>)) + +(define* (report-package-coverage-per-system server packages system + #:key (threshold 0)) + "Report on the subset of PACKAGES that lacks SYSTEM substitutes on SERVER, +sorted by decreasing number of dependents. Do not display those with less +than THRESHOLD dependents." + (mlet* %store-monad ((packages -> (package-closure packages #:system system)) + (mapping (package->output-mapping packages system)) + (back-edges (node-back-edges %bag-node-type packages))) + (define items + (vhash-fold (lambda (package items result) + (append items result)) + '() + mapping)) + + (define substitutable? + (substitute-oracle server items)) + + (define substitutable-package? + (lambda (package) + (match (vhash-assq package mapping) + ((_ . items) + (find substitutable? items)) + (#f + #f)))) + + (define missing + (package-partition-boundary substitutable-package? packages + #:system system)) + + (define missing-count + (length missing)) + + (if (zero? threshold) + (format #t (N_ "The following ~a package is missing from '~a' for \ +'~a':~%" + "The following ~a packages are missing from '~a' for \ +'~a':~%" + missing-count) + missing-count server system) + (format #t (N_ "~a package is missing from '~a' for '~a':~%" + "~a packages are missing from '~a' for '~a', among \ +which:~%" + missing-count) + missing-count server system)) + + (for-each (match-lambda + ((package count) + (match (vhash-assq package mapping) + ((_ . items) + (when (>= count threshold) + (format #t " ~4d\t~a@~a\t~{~a ~}~%" + count + (package-name package) (package-version package) + items))) + (#f ;PACKAGE must be an internal thing + #f)))) + (sort (zip missing + (map (lambda (package) + (node-reachable-count (list package) + back-edges)) + missing)) + (match-lambda* + (((_ count1) (_ count2)) + (< count2 count1))))) + (return #t))) + +(define* (report-package-coverage server packages systems + #:key (threshold 0)) + "Report on the substitute coverage for PACKAGES, for each of SYSTEMS, on +SERVER. Display information for packages with at least THRESHOLD dependents." + (with-store store + (run-with-store store + (foldm %store-monad + (lambda (system _) + (report-package-coverage-per-system server packages system + #:threshold threshold)) + #f + systems)))) + + +;;; ;;; Entry point. ;;; @@ -331,7 +494,12 @@ Report the availability of substitutes.\n")) (package-outputs packages system)) systems))))))) (for-each (lambda (server) - (report-server-coverage server items)) + (report-server-coverage server items) + (match (assoc-ref opts 'coverage) + (#f #f) + (threshold + (report-package-coverage server packages systems + #:threshold threshold)))) urls))))) ;;; Local Variables: |