diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 50 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 118 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 89 | ||||
| -rw-r--r-- | guix/scripts/deploy.scm | 55 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 142 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 38 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 208 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 33 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 137 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 98 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 7 |
12 files changed, 486 insertions, 496 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 4f39920fe7..80f3b704d7 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -259,12 +259,7 @@ 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))) - (show-what-to-build store drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?)) - - (if (or (assoc-ref opts 'dry-run?) - (build-derivations store drv)) + (if (build-derivations store drv) (export-paths store files (current-output-port) #:recursive? (assoc-ref opts 'export-recursive?)) (leave (G_ "unable to export the given packages~%"))))) @@ -382,22 +377,27 @@ output port." (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 'list) - (list-contents (current-input-port))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (G_ "either '--export' or '--import' \ -must be specified~%")))))))))))) + (with-build-handler + (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (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 'list) + (list-contents (current-input-port))) + ((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 da2a675ce2..af18d8b6f9 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -952,64 +952,60 @@ needed." ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((current-terminal-columns (terminal-columns)) - - ;; Set grafting upfront in case the user's input - ;; depends on it (e.g., a manifest or code snippet that - ;; calls 'gexp->derivation'). - (%graft? graft?)) - (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)) - ;; If FILE is a .drv that's not in - ;; store, keep it so that it can be - ;; substituted. - (and (or (not (derivation-path? file)) - (not (file-exists? 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?) - ;; Pass 'show-build-log' the output file names, not the - ;; derivation file names, because there can be several - ;; derivations leading to the same output. - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation->output-path 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 (append drv items) - 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-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (parameterize ((current-terminal-columns (terminal-columns)) + + ;; Set grafting upfront in case the user's input + ;; depends on it (e.g., a manifest or code snippet that + ;; calls 'gexp->derivation'). + (%graft? graft?)) + (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)) + ;; If FILE is a .drv that's not in + ;; store, keep it so that it can be + ;; substituted. + (and (or (not (derivation-path? file)) + (not (file-exists? file))) + file)) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (cond ((assoc-ref opts 'log-file?) + ;; Pass 'show-build-log' the output file names, not the + ;; derivation file names, because there can be several + ;; derivations leading to the same output. + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation->output-path 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)) + (else + (and (build-derivations store (append drv items) + 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/copy.scm b/guix/scripts/copy.scm index 664cb32b7c..2fa31ecf45 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, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,49 +61,40 @@ number (or #f) corresponding to SPEC." (x (leave (G_ "~a: invalid SSH specification~%") spec)))) -(define (send-to-remote-host target opts) +(define (send-to-remote-host local target opts) "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; package names, build the underlying packages before sending them." - (with-store local - (set-build-options-from-command-line local opts) - (let-values (((user host port) - (ssh-spec->user+host+port target)) - ((drv items) - (options->derivations+files local opts))) - (show-what-to-build local drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?)) + (let-values (((user host port) + (ssh-spec->user+host+port target)) + ((drv items) + (options->derivations+files local opts))) + (and (build-derivations local drv) + (let* ((session (open-ssh-session host #:user user + #:port (or port 22))) + (sent (send-files local items + (connect-to-remote-daemon session) + #:recursive? #t))) + (format #t "~{~a~%~}" sent) + sent)))) - (and (or (assoc-ref opts 'dry-run?) - (build-derivations local drv)) - (let* ((session (open-ssh-session host #:user user - #:port (or port 22))) - (sent (send-files local items - (connect-to-remote-daemon session) - #:recursive? #t))) - (format #t "~{~a~%~}" sent) - sent))))) - -(define (retrieve-from-remote-host source opts) +(define (retrieve-from-remote-host local source opts) "Retrieve ITEMS from SOURCE." - (with-store local - (let*-values (((user host port) - (ssh-spec->user+host+port source)) - ((session) - (open-ssh-session host #:user user #:port (or port 22))) - ((remote) - (connect-to-remote-daemon session))) - (set-build-options-from-command-line local opts) - ;; TODO: Here we could to compute and build the derivations on REMOTE - ;; rather than on LOCAL (one-off offloading) but that is currently too - ;; slow due to the many RPC round trips. So we just assume that REMOTE - ;; contains ITEMS. - (let*-values (((drv items) - (options->derivations+files local opts)) - ((retrieved) - (retrieve-files local items remote #:recursive? #t))) - (format #t "~{~a~%~}" retrieved) - retrieved)))) + (let*-values (((user host port) + (ssh-spec->user+host+port source)) + ((session) + (open-ssh-session host #:user user #:port (or port 22))) + ((remote) + (connect-to-remote-daemon session))) + ;; TODO: Here we could to compute and build the derivations on REMOTE + ;; rather than on LOCAL (one-off offloading) but that is currently too + ;; slow due to the many RPC round trips. So we just assume that REMOTE + ;; contains ITEMS. + (let*-values (((drv items) + (options->derivations+files local opts)) + ((retrieved) + (retrieve-files local items remote #:recursive? #t))) + (format #t "~{~a~%~}" retrieved) + retrieved))) ;;; @@ -142,6 +133,10 @@ Copy ITEMS to or from the specified host over SSH.\n")) (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)))) + (option '(#\h "help") #f #f (lambda args (show-help) @@ -176,7 +171,13 @@ 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))) - (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'~%")))))))) + (with-store store + (set-build-options-from-command-line store opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (with-status-verbosity (assoc-ref opts 'verbosity) + (cond (target (send-to-remote-host store target opts)) + (source (retrieve-from-remote-host store source opts)) + (else (leave (G_ "use '--to' or '--from'~%")))))))))) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index ad05c333dc..f70d41f35c 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 David Thompson <davet@gnu.org> ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,6 +98,22 @@ Perform the deployment specified by FILE.\n")) environment-modules)))) (load* file module))) +(define (show-what-to-deploy machines) + "Show the list of machines to deploy, MACHINES." + (let ((count (length machines))) + (format (current-error-port) + (N_ "The following ~*machine will be deployed:~%" + "The following ~d machines will be deployed:~%" + count) + count) + (display (indented-string + (fill-paragraph (string-join (map machine-display-name machines) + ", ") + (- (%text-width) 2) 2) + 2) + (current-error-port)) + (display "\n\n" (current-error-port)))) + (define (guix-deploy . args) (define (handle-argument arg result) (alist-cons 'file arg result)) @@ -105,22 +122,28 @@ Perform the deployment specified by FILE.\n")) #:argument-handler handle-argument)) (file (assq-ref opts 'file)) (machines (or (and file (load-source-file file)) '()))) + (show-what-to-deploy machines) + (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store (set-build-options-from-command-line store opts) - (for-each (lambda (machine) - (info (G_ "deploying to ~a...~%") - (machine-display-name machine)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (guard (c ((message-condition? c) - (report-error (G_ "failed to deploy ~a: ~a~%") - (machine-display-name machine) - (condition-message c))) - ((deploy-error? c) - (when (deploy-error-should-roll-back c) - (info (G_ "rolling back ~a...~%") - (machine-display-name machine)) - (run-with-store store (roll-back-machine machine))) - (apply throw (deploy-error-captured-args c)))) - (run-with-store store (deploy-machine machine))))) - machines))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (for-each (lambda (machine) + (info (G_ "deploying to ~a...~%") + (machine-display-name machine)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (guard (c ((message-condition? c) + (report-error (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (condition-message c))) + ((deploy-error? c) + (when (deploy-error-should-roll-back c) + (info (G_ "rolling back ~a...~%") + (machine-display-name machine)) + (run-with-store store (roll-back-machine machine))) + (apply throw (deploy-error-captured-args c)))) + (run-with-store store (deploy-machine machine)) + (info (G_ "successfully deployed ~a~%") + (machine-display-name machine))))) + machines)))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index e2fe8051b9..e6f45d3eba 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -362,19 +362,6 @@ for the corresponding packages." opts) manifest-entry=?))) -(define* (build-environment derivations opts) - "Build the DERIVATIONS required by the environment using the build options -in OPTS." - (let ((substitutes? (assoc-ref opts 'substitutes?)) - (dry-run? (assoc-ref opts 'dry-run?))) - (mbegin %store-monad - (show-what-to-build* derivations - #:use-substitutes? substitutes? - #:dry-run? dry-run?) - (if dry-run? - (return #f) - (built-derivations derivations))))) - (define (manifest->derivation manifest system bootstrap?) "Return the derivation for a profile of MANIFEST. BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile." @@ -718,67 +705,68 @@ message if any test fails." (with-store store - (with-status-verbosity (assoc-ref opts 'verbosity) - (define manifest - (options/resolve-packages store opts)) - - (set-build-options-from-command-line store opts) - - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (default-guile))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (manifest->derivation - manifest system bootstrap?)) - (profile -> (derivation->output-path prof-drv)) - (gc-root -> (assoc-ref opts 'gc-root))) - - ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash for - ;; a container. - (mbegin %store-monad - (build-environment (if (derivation? bash) - (list prof-drv bash) - (list prof-drv)) - opts) - (mwhen gc-root - (register-gc-root profile gc-root)) - - (cond - ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths profile manifest #:pure? pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - (derivation->output-path bash) - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user user - #:user-mappings mappings - #:profile profile - #:manifest manifest - #:white-list white-list - #:link-profile? link-prof? - #:network? network? - #:map-cwd? (not no-cwd?)))) - - (else - (return - (exit/status - (launch-environment/fork command profile manifest - #:white-list white-list - #:pure? pure?)))))))))))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (with-status-verbosity (assoc-ref opts 'verbosity) + (define manifest + (options/resolve-packages store opts)) + + (set-build-options-from-command-line store opts) + + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (default-guile))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (manifest->derivation + manifest system bootstrap?)) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) + + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (built-derivations (if (derivation? bash) + (list prof-drv bash) + (list prof-drv))) + (mwhen gc-root + (register-gc-root profile gc-root)) + + (cond + ((assoc-ref opts 'search-paths) + (show-search-paths profile manifest #:pure? pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + (derivation->output-path bash) + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user user + #:user-mappings mappings + #:profile profile + #:manifest manifest + #:white-list white-list + #:link-profile? link-prof? + #:network? network? + #:map-cwd? (not no-cwd?)))) + + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:white-list white-list + #:pure? pure?))))))))))))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 8d08c484f5..97ffd57301 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -30,6 +30,7 @@ #:use-module (guix packages) #:use-module (guix lint) #:use-module (guix ui) + #:use-module (guix store) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) @@ -53,7 +54,7 @@ (lint-warning-message lint-warning)))) warnings)) -(define (run-checkers package checkers) +(define* (run-checkers package checkers #:key store) "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port)))) (for-each (lambda (checker) @@ -63,7 +64,9 @@ (lint-checker-name checker)) (force-output (current-error-port))) (emit-warnings - ((lint-checker-check checker) package))) + (if (lint-checker-requires-store? checker) + ((lint-checker-check checker) package #:store store) + ((lint-checker-check checker) package)))) checkers) (when tty? (format (current-error-port) "\x1b[K") @@ -167,12 +170,27 @@ run the checkers on all packages.\n")) (_ #f)) (reverse opts))) (checkers (or (assoc-ref opts 'checkers) %all-checkers))) - (cond - ((assoc-ref opts 'list?) + + (when (assoc-ref opts 'list?) (list-checkers-and-exit checkers)) - ((null? args) - (fold-packages (lambda (p r) (run-checkers p checkers)) '())) - (else - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers)) - args))))) + + (let ((any-lint-checker-requires-store? + (any lint-checker-requires-store? checkers))) + + (define (call-maybe-with-store proc) + (if any-lint-checker-requires-store? + (with-store store + (proc store)) + (proc #f))) + + (call-maybe-with-store + (lambda (store) + (cond + ((null? args) + (fold-packages (lambda (p r) (run-checkers p checkers + #:store store)) '())) + (else + (for-each (lambda (spec) + (run-checkers (specification->package spec) checkers + #:store store)) + args)))))))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 045fd1643e..9d981c05d6 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -373,6 +373,10 @@ added to the pack." ;; file system since it's useless in this case. "-no-recovery" + ;; Do not attempt to store extended attributes. + ;; See <https://bugs.gnu.org/40043>. + "-no-xattrs" + ;; Set file times and the file system creation time to ;; one second after the Epoch. "-all-time" "1" "-mkfs-time" "1" @@ -1022,108 +1026,106 @@ Create a bundle of PACKAGE.\n")) ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (default-guile)) - (assoc-ref opts 'system) - #:graft? (assoc-ref opts 'graft?)))) - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (derivation? (assoc-ref opts 'derivation-only?)) - (relocatable? (assoc-ref opts 'relocatable?)) - (proot? (eq? relocatable? 'proot)) - (manifest (let ((manifest (manifest-from-args store opts))) - ;; Note: We cannot honor '--bootstrap' here because - ;; 'glibc-bootstrap' lacks 'libc.a'. - (if relocatable? - (map-manifest-entries - (cut wrapped-manifest-entry <> #:proot? proot?) - manifest) - manifest))) - (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) - (target (assoc-ref opts 'target)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (compressor (if bootstrap? - bootstrap-xz - (assoc-ref opts 'compressor))) - (archiver (if (equal? pack-format 'squashfs) - squashfs-tools - (if bootstrap? - %bootstrap-coreutils&co - tar))) - (symlinks (assoc-ref opts 'symlinks)) - (build-image (match (assq-ref %formats pack-format) - ((? procedure? proc) proc) - (#f - (leave (G_ "~a: unknown pack format~%") - pack-format)))) - (localstatedir? (assoc-ref opts 'localstatedir?)) - (entry-point (assoc-ref opts 'entry-point)) - (profile-name (assoc-ref opts 'profile-name)) - (gc-root (assoc-ref opts 'gc-root))) - (define (lookup-package package) - (manifest-lookup manifest (manifest-pattern (name package)))) - - (when (null? (manifest-entries manifest)) - (warning (G_ "no packages specified; building an empty pack~%"))) - - (when (and (eq? pack-format 'squashfs) - (not (any lookup-package '("bash" "bash-minimal")))) - (warning (G_ "Singularity requires you to provide a shell~%")) - (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \ + (with-build-handler (build-notifier #:dry-run? + (assoc-ref opts 'dry-run?) + #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (default-guile)) + (assoc-ref opts 'system) + #:graft? (assoc-ref opts 'graft?)))) + (let* ((derivation? (assoc-ref opts 'derivation-only?)) + (relocatable? (assoc-ref opts 'relocatable?)) + (proot? (eq? relocatable? 'proot)) + (manifest (let ((manifest (manifest-from-args store opts))) + ;; Note: We cannot honor '--bootstrap' here because + ;; 'glibc-bootstrap' lacks 'libc.a'. + (if relocatable? + (map-manifest-entries + (cut wrapped-manifest-entry <> #:proot? proot?) + manifest) + manifest))) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (compressor (if bootstrap? + bootstrap-xz + (assoc-ref opts 'compressor))) + (archiver (if (equal? pack-format 'squashfs) + squashfs-tools + (if bootstrap? + %bootstrap-coreutils&co + tar))) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (G_ "~a: unknown pack format~%") + pack-format)))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (entry-point (assoc-ref opts 'entry-point)) + (profile-name (assoc-ref opts 'profile-name)) + (gc-root (assoc-ref opts 'gc-root))) + (define (lookup-package package) + (manifest-lookup manifest (manifest-pattern (name package)))) + + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; building an empty pack~%"))) + + (when (and (eq? pack-format 'squashfs) + (not (any lookup-package '("bash" "bash-minimal")))) + (warning (G_ "Singularity requires you to provide a shell~%")) + (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \ to your package list."))) - (run-with-store store - (mlet* %store-monad ((profile (profile-derivation - manifest - - ;; Always produce relative - ;; symlinks for Singularity (see - ;; <https://bugs.gnu.org/34913>). - #:relative-symlinks? - (or relocatable? - (eq? 'squashfs pack-format)) - - #:hooks (if bootstrap? - '() - %default-profile-hooks) - #:locales? (not bootstrap?) - #:target target)) - (drv (build-image name profile - #:target - target - #:compressor - compressor - #:symlinks - symlinks - #:localstatedir? - localstatedir? - #:entry-point - entry-point - #:profile-name - profile-name - #:archiver - archiver))) - (mbegin %store-monad - (munless derivation? - (show-what-to-build* (list drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?)) - (mwhen derivation? - (return (format #t "~a~%" - (derivation-file-name drv)))) - (munless (or derivation? dry-run?) - (built-derivations (list drv)) - (mwhen gc-root - (register-root* (match (derivation->output-paths drv) - (((names . items) ...) - items)) - gc-root)) - (return (format #t "~a~%" - (derivation->output-path drv)))))) - #:system (assoc-ref opts 'system)))))))) + (run-with-store store + (mlet* %store-monad ((profile (profile-derivation + manifest + + ;; Always produce relative + ;; symlinks for Singularity (see + ;; <https://bugs.gnu.org/34913>). + #:relative-symlinks? + (or relocatable? + (eq? 'squashfs pack-format)) + + #:hooks (if bootstrap? + '() + %default-profile-hooks) + #:locales? (not bootstrap?) + #:target target)) + (drv (build-image name profile + #:target + target + #:compressor + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir? + #:entry-point + entry-point + #:profile-name + profile-name + #:archiver + archiver))) + (mbegin %store-monad + (mwhen derivation? + (return (format #t "~a~%" + (derivation-file-name drv)))) + (munless derivation? + (built-derivations (list drv)) + (mwhen gc-root + (register-root* (match (derivation->output-paths drv) + (((names . items) ...) + items)) + gc-root)) + (return (format #t "~a~%" + (derivation->output-path drv)))))) + #:system (assoc-ref opts 'system))))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index bdddc11b7b..8af0a7a27e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -130,8 +130,7 @@ denote ranges as interpreted by 'matching-generations'." #:key (hooks %default-profile-hooks) allow-collisions? - bootstrap? use-substitutes? - dry-run?) + bootstrap?) "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. HOOKS is a list of \"profile @@ -142,12 +141,8 @@ hooks\" run when building the profile." #:hooks (if bootstrap? '() hooks) #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) - (show-what-to-build store (list prof-drv) - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?) (cond - (dry-run? #t) ((and (file-exists? profile) (and=> (readlink* profile) (cut string=? prof <>))) (format (current-error-port) (G_ "nothing to be done~%"))) @@ -164,10 +159,6 @@ hooks\" run when building the profile." (switch-symlinks profile (basename name)) (unless (string=? profile %current-profile) (register-gc-root store name)) - (format #t (N_ "~a package in profile~%" - "~a packages in profile~%" - count) - count) (display-search-path-hint entries profile))) (warn-about-disk-space profile)))))) @@ -918,9 +909,7 @@ processed, #f otherwise." #:dry-run? dry-run?) (build-and-use-profile store profile new #:allow-collisions? allow-collisions? - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?))))) + #:bootstrap? bootstrap?))))) ;;; @@ -949,10 +938,14 @@ option processing with 'parse-command-line'." (%graft? (assoc-ref opts 'graft?))) (with-status-verbosity (assoc-ref opts 'verbosity) (set-build-options-from-command-line (%store) opts) - (parameterize ((%guile-for-build - (package-derivation - (%store) - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (default-guile))))) - (process-actions (%store) opts))))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (parameterize ((%guile-for-build + (package-derivation + (%store) + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (default-guile))))) + (process-actions (%store) opts)))))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 1c5456026c..dbd02431fe 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -269,7 +269,7 @@ code, to PORT." (let ((body (or (assoc-ref body language) (assoc-ref body (%default-message-language)) ""))) - (format port " ~a~%" + (format port "~a~%" (indented-string (parameterize ((%text-width (- (%text-width) 4))) (string-trim-right @@ -389,8 +389,7 @@ previous generation. Return true if there are news to display." (display-channel-news profile)) -(define* (build-and-install instances profile - #:key use-substitutes? dry-run?) +(define* (build-and-install instances profile) "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is true, display what would be built without actually building it." (define update-profile @@ -403,29 +402,27 @@ 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 - #:use-substitutes? use-substitutes? - #:hooks %channel-profile-hooks - #:dry-run? dry-run?) - (munless dry-run? - (return (newline)) - (return - (let ((more? (list (display-profile-news profile #:concise? #t) - (display-channel-news-headlines profile)))) - (when (any ->bool more?) - (display-hint - (G_ "Run @command{guix pull --news} to read all the news."))))) - (if guix-command - (let ((new (map (cut string-append <> "/bin/guix") - (list (user-friendly-profile profile) - profile)))) - ;; Is the 'guix' command previously in $PATH the same as the new - ;; one? If the answer is "no", then suggest 'hash guix'. - (unless (member guix-command new) - (display-hint (format #f (G_ "After setting @code{PATH}, run + #:hooks %channel-profile-hooks) + + (return + (let ((more? (list (display-profile-news profile #:concise? #t) + (display-channel-news-headlines profile)))) + (newline) + (when (any ->bool more?) + (display-hint + (G_ "Run @command{guix pull --news} to read all the news."))))) + (if guix-command + (let ((new (map (cut string-append <> "/bin/guix") + (list (user-friendly-profile profile) + profile)))) + ;; Is the 'guix' command previously in $PATH the same as the new + ;; one? If the answer is "no", then suggest 'hash guix'. + (unless (member guix-command 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)) - (return #f)))))) + (first new)))) + (return #f)) + (return #f))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -523,19 +520,6 @@ true, display what would be built without actually building it." ;;; Queries. ;;; -(define (indented-string str indent) - "Return STR with each newline preceded by IDENT spaces." - (define indent-string - (make-list indent #\space)) - - (list->string - (string-fold-right (lambda (chr result) - (if (eqv? chr #\newline) - (cons chr (append indent-string result)) - (cons chr result))) - '() - str))) - (define profile-package-alist (mlambda (profile) "Return a name/version alist representing the packages in PROFILE." @@ -592,7 +576,7 @@ Return true when there is more package info to display." (define (pretty str column) (indented-string (fill-paragraph str (- (%text-width) 4) column) - 4)) + 4 #:initial-indent? #f)) (define concise/max-item-count ;; Maximum number of items to display when CONCISE? is true. @@ -760,10 +744,12 @@ Use '~/.config/guix/channels.scm' instead.")) (define (guix-pull . args) (with-error-handling (with-git-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options))) - (channels (channel-list opts)) - (profile (or (assoc-ref opts 'profile) %current-profile))) + (let* ((opts (parse-command-line args %options + (list %default-options))) + (substitutes? (assoc-ref opts 'substitutes?)) + (dry-run? (assoc-ref opts 'dry-run?)) + (channels (channel-list opts)) + (profile (or (assoc-ref opts 'profile) %current-profile))) (cond ((assoc-ref opts 'query) (process-query opts profile)) ((assoc-ref opts 'generation) @@ -773,38 +759,37 @@ Use '~/.config/guix/channels.scm' instead.")) (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line store opts) - (ensure-default-profile) - (honor-x509-certificates store) - - (let ((instances (latest-channel-instances store channels))) - (format (current-error-port) - (N_ "Building from this channel:~%" - "Building from these channels:~%" - (length instances))) - (for-each (lambda (instance) - (let ((channel - (channel-instance-channel instance))) - (format (current-error-port) - " ~10a~a\t~a~%" - (channel-name channel) - (channel-url channel) - (string-take - (channel-instance-commit instance) - 7)))) - instances) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (default-guile))))) - (with-profile-lock profile - (run-with-store store - (build-and-install instances profile - #:dry-run? - (assoc-ref opts 'dry-run?) - #:use-substitutes? - (assoc-ref opts 'substitutes?))))))))))))))) + (with-build-handler (build-notifier #:use-substitutes? + substitutes? + #:dry-run? dry-run?) + (set-build-options-from-command-line store opts) + (ensure-default-profile) + (honor-x509-certificates store) + + (let ((instances (latest-channel-instances store channels))) + (format (current-error-port) + (N_ "Building from this channel:~%" + "Building from these channels:~%" + (length instances))) + (for-each (lambda (instance) + (let ((channel + (channel-instance-channel instance))) + (format (current-error-port) + " ~10a~a\t~a~%" + (channel-name channel) + (channel-url channel) + (string-take + (channel-instance-commit instance) + 7)))) + instances) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (default-guile))))) + (with-profile-lock profile + (run-with-store store + (build-and-install instances profile))))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index dfb975a24a..95b47a7816 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -102,13 +102,6 @@ ;;; ;;; Code: -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - (define %narinfo-cache-directory ;; A local cache of narinfos, to avoid going to the network. Most of the ;; time, 'guix substitute' is called by guix-daemon as root and stores its diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ac2475c551..61a3c95dbd 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, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> @@ -27,6 +27,7 @@ #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix store) #:autoload (guix store database) (register-path) + #:use-module (guix describe) #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) @@ -403,7 +404,6 @@ STORE is an open connection to the store." #:old-entries old-entries))) (drvs -> (list bootcfg))) (mbegin %store-monad - (show-what-to-build* drvs) (built-derivations drvs) ;; Only install bootloader configuration file. (install-bootloader local-eval bootloader-config bootcfg @@ -719,16 +719,11 @@ checking this by themselves in their 'check' procedure." (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." - ;; The reason for this is that the 'guix' binding that we see here comes - ;; from either ~/.config/latest or, if it's missing, from the - ;; globally-installed Guix, which is necessarily older. See - ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for - ;; a discussion. - (define latest - (string-append (config-directory) "/current")) - - (unless (file-exists? latest) - (warning (G_ "~a not found: 'guix pull' was never run~%") latest) + ;; Check whether we're running a 'guix pull'-provided 'guix' command. When + ;; 'current-profile' returns #f, we may be running the globally-installed + ;; 'guix' and thus run the risk of deploying an older 'guix'. See + ;; <https://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> + (unless (or (current-profile) (getenv "GUIX_UNINSTALLED")) (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) (warning (G_ "Failing to do that may downgrade your system!~%")))) @@ -837,8 +832,7 @@ static checks." (% (if derivations-only? (return (for-each (compose println derivation-file-name) drvs)) - (maybe-build drvs #:dry-run? dry-run? - #:use-substitutes? use-substitutes?)))) + (built-derivations drvs)))) (if (or dry-run? derivations-only?) (return #f) @@ -1139,42 +1133,46 @@ resulting from command-line parsing." (with-store store (set-build-options-from-command-line store opts) - (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (case action - ((extension-graph) - (export-extension-graph os (current-output-port))) - ((shepherd-graph) - (export-shepherd-graph os (current-output-port))) - (else - (unless (memq action '(build init)) - (warn-about-old-distro #:suggested-command - "guix system reconfigure")) - - (perform-action action os - #:dry-run? dry? - #:derivations-only? (assoc-ref opts - 'derivations-only?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:skip-safety-checks? - (assoc-ref opts 'skip-safety-checks?) - #:file-system-type (assoc-ref opts 'file-system-type) - #:image-size (assoc-ref opts 'image-size) - #:full-boot? (assoc-ref opts 'full-boot?) - #:container-shared-network? - (assoc-ref opts 'container-shared-network?) - #:mappings (filter-map (match-lambda - (('file-system-mapping . m) - m) - (_ #f)) - opts) - #:install-bootloader? bootloader? - #:target target-file - #:bootloader-target bootloader-target - #:gc-root (assoc-ref opts 'gc-root))))) - #:target target - #:system system)) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (case action + ((extension-graph) + (export-extension-graph os (current-output-port))) + ((shepherd-graph) + (export-shepherd-graph os (current-output-port))) + (else + (unless (memq action '(build init)) + (warn-about-old-distro #:suggested-command + "guix system reconfigure")) + + (perform-action action os + #:dry-run? dry? + #:derivations-only? (assoc-ref opts + 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:skip-safety-checks? + (assoc-ref opts 'skip-safety-checks?) + #:file-system-type (assoc-ref opts 'file-system-type) + #:image-size (assoc-ref opts 'image-size) + #:full-boot? (assoc-ref opts 'full-boot?) + #:container-shared-network? + (assoc-ref opts 'container-shared-network?) + #:mappings (filter-map (match-lambda + (('file-system-mapping . m) + m) + (_ #f)) + opts) + #:install-bootloader? bootloader? + #:target target-file + #:bootloader-target bootloader-target + #:gc-root (assoc-ref opts 'gc-root))))) + #:target target + #:system system))) (warn-about-disk-space))) (define (resolve-subcommand name) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index a9e0cba92a..eb76771452 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -106,13 +106,6 @@ scope." '() packages))))) -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - (define (call-with-time thunk kont) "Call THUNK and pass KONT the elapsed time followed by THUNK's return values." |