From 62195b9a8fd6846117c5d7698842748300d13e31 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 18 Mar 2020 22:46:39 +0100 Subject: guix build: Use 'with-build-handler'. Fixes . Reported by Andreas Enge . * guix/scripts/build.scm (guix-build): Wrap 'parameterize' in 'with-build-handler'. Remove explicit call to 'show-what-to-build'. Call 'build-derivations' regardless of whether OPTS contains 'dry-run?'. --- guix/scripts/build.scm | 118 ++++++++++++++++++++++++------------------------- 1 file changed, 57 insertions(+), 61 deletions(-) (limited to 'guix/scripts') 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))))))))))) -- cgit v1.2.3 From bdda46a67d5b8d9d45a53a7d6b32d9acb9374ae2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 18 Mar 2020 22:57:28 +0100 Subject: deploy: Use 'with-build-handler'. Until now, 'guix deploy' would never display what is going to be built. * guix/scripts/deploy.scm (guix-deploy): Wrap 'for-each' in 'with-build-handler'. --- guix/scripts/deploy.scm | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index ad05c333dc..a82dde00a4 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -108,19 +108,21 @@ Perform the deployment specified by FILE.\n")) (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))))) + machines)))))) -- cgit v1.2.3 From 5f5e9a5cd63352875ea968f89bc4b8cb4318cc02 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 18 Mar 2020 23:00:13 +0100 Subject: pack: Use 'with-build-handler'. * guix/scripts/pack.scm (guix-pack): Wrap 'parameterize' in 'with-build-handler'. Remove explicit call to 'show-what-to-build'. Call 'build-derivations' regardless of whether OPTS contains 'dry-run?'. --- guix/scripts/pack.scm | 204 +++++++++++++++++++++++++------------------------- 1 file changed, 101 insertions(+), 103 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 652b4c63c4..6829d7265f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1022,108 +1022,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 - (canonical-package guile-2.2)) - (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 + (canonical-package guile-2.2)) + (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 - ;; ). - #: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 + ;; ). + #: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))))))))) -- cgit v1.2.3 From 65ffb9388c1c3d870cb07e4cb3ef12c9ac06a161 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 19 Mar 2020 10:42:28 +0100 Subject: guix package, pull: Use 'with-build-handler'. * guix/scripts/package.scm (build-and-use-profile): Remove #:dry-run? and #:use-substitutes?. Remove call to 'show-what-to-build' and 'dry-run?' special case. (process-actions): Adjust accordingly. (guix-package*): Wrap 'parameterize' in 'with-build-handler'. * guix/scripts/pull.scm (build-and-install): Remove #:use-substitutes? and #:dry-run? and adjust 'update-profile' call accordingly. Remove 'dry-run?' conditional. (guix-pull): Wrap body in 'with-build-handler'. --- guix/scripts/package.scm | 29 +++++------- guix/scripts/pull.scm | 120 +++++++++++++++++++++++------------------------ 2 files changed, 72 insertions(+), 77 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e620309e30..b5d16acec0 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -132,8 +132,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 @@ -144,12 +143,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~%"))) @@ -920,9 +915,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?))))) ;;; @@ -951,10 +944,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 - (canonical-package guile-2.2))))) - (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 + (canonical-package guile-2.2))))) + (process-actions (%store) opts)))))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 51d4da209a..7fc23e1b47 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -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." @@ -760,10 +757,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 +772,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 - (canonical-package guile-2.2))))) - (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 + (canonical-package guile-2.2))))) + (with-profile-lock profile + (run-with-store store + (build-and-install instances profile))))))))))))))) ;;; pull.scm ends here -- cgit v1.2.3 From a0f480d623f71b7f0d93de192b86038317dc625b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 19 Mar 2020 11:17:34 +0100 Subject: guix system: Use 'with-build-handler'. * guix/scripts/system.scm (reinstall-bootloader): Remove call to 'show-what-to-build*'. (perform-action): Call 'build-derivations' instead of 'maybe-build'. (process-action): Wrap 'run-with-store' in 'with-build-handler'. --- guix/scripts/system.scm | 82 +++++++++++++++++++++++++------------------------ 1 file changed, 42 insertions(+), 40 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ac2475c551..8d1938281a 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017, 2019 Mathieu Othacehe @@ -403,7 +403,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 @@ -837,8 +836,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 +1137,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) -- cgit v1.2.3 From 7473238f7de28f9c85e364364c3155a3bbb877ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 22 Mar 2020 12:19:49 +0100 Subject: copy: Factorize 'with-store' & co. * guix/scripts/copy.scm (send-to-remote-host): Remove 'with-store' and 'set-build-options-from-command-line' call. Add 'local' parameter. (retrieve-from-remote-host): Likewise. (guix-copy): Wrap 'with-status-verbosity' in 'with-store' and add call to 'set-build-options-from-command-line'. --- guix/scripts/copy.scm | 84 +++++++++++++++++++++++++-------------------------- 1 file changed, 41 insertions(+), 43 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 664cb32b7c..2542df6b19 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 +;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,49 +61,45 @@ 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))) + (show-what-to-build local drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) - (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))))) + (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))) ;;; @@ -176,7 +172,9 @@ 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-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'~%"))))))))) -- cgit v1.2.3 From 81c0b52bd6301a7ded157b270097a8074c8f2d50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 22 Mar 2020 12:25:39 +0100 Subject: copy: Actually implement '--dry-run'. * guix/scripts/copy.scm (%options): Add '--dry-run'. --- guix/scripts/copy.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix/scripts') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 2542df6b19..fdb684c6b6 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -138,6 +138,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) -- cgit v1.2.3 From 3e6f65be7ae6f895ceb38f9a129c95e08761182b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 22 Mar 2020 12:26:05 +0100 Subject: copy: Use 'with-build-handler'. * guix/scripts/copy.scm (send-to-remote-host): Remove explicit 'show-what-to-build' call. Call 'build-derivations' unconditionally. (guix-copy): Wrap 'with-status-verbosity' in 'with-build-handler'. --- guix/scripts/copy.scm | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index fdb684c6b6..2fa31ecf45 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -68,12 +68,7 @@ package names, build the underlying packages before sending them." (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?)) - - (and (or (assoc-ref opts 'dry-run?) - (build-derivations local drv)) + (and (build-derivations local drv) (let* ((session (open-ssh-session host #:user user #:port (or port 22))) (sent (send-files local items @@ -178,7 +173,11 @@ Copy ITEMS to or from the specified host over SSH.\n")) (target (assoc-ref opts 'destination))) (with-store store (set-build-options-from-command-line store opts) - (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'~%"))))))))) + (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'~%")))))))))) -- cgit v1.2.3 From 9acacb71c958218fd69cf0fb9df0b439a980a0f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 22 Mar 2020 15:58:49 +0100 Subject: Remove workaround for 'time-monotonic' in Guile 2.2.2. This is a followup to e688c2df3924423b67892cc9939ca099c729d1cb. * build-aux/hydra/evaluate.scm : Remove 'time-monotonic' definition. * guix/cache.scm: Likewise. * guix/progress.scm: Likewise. * guix/scripts/substitute.scm: Likewise. * guix/scripts/weather.scm: Likewise. * tests/cache.scm: Likewise. --- guix/scripts/substitute.scm | 7 ------- guix/scripts/weather.scm | 7 ------- 2 files changed, 14 deletions(-) (limited to 'guix/scripts') 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/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." -- cgit v1.2.3 From 7b322d3c4cb266a0d84f5e3a8ceedd302f9f73df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 20 Mar 2020 12:44:43 +0100 Subject: ui: Add 'indented-string'. * guix/scripts/pull.scm (display-news-entry): Remove extra space in format string for 'indented-string'. (indented-string): Remove. (display-new/upgraded-packages)[pretty]: Pass #:initial-indent? to 'indented-string'. * guix/ui.scm (indented-string): New procedure. --- guix/scripts/pull.scm | 17 ++--------------- 1 file changed, 2 insertions(+), 15 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 7fc23e1b47..b7e0a4a416 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 @@ -520,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." @@ -589,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. -- cgit v1.2.3 From 1bb248d0b10af77379096f4456ce6f5c5d1c23ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 20 Mar 2020 12:46:06 +0100 Subject: deploy: Show what machines will be deployed. * guix/scripts/deploy.scm (show-what-to-deploy): New procedure. (guix-deploy): Call it. --- guix/scripts/deploy.scm | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'guix/scripts') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index a82dde00a4..d4d07bea5a 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 ;;; Copyright © 2019 Jakob L. Kreuze +;;; Copyright © 2020 Ludovic Courtès ;;; ;;; 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,6 +122,8 @@ 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) -- cgit v1.2.3 From 129237272505d58e121c40b938c7227f294ecb82 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 20 Mar 2020 14:52:01 +0100 Subject: deploy: Write a message upon successful deployment. * guix/scripts/deploy.scm (guix-deploy): Write message upon successful deployment. --- guix/scripts/deploy.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index d4d07bea5a..f70d41f35c 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -143,5 +143,7 @@ Perform the deployment specified by FILE.\n")) (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))))) + (run-with-store store (deploy-machine machine)) + (info (G_ "successfully deployed ~a~%") + (machine-display-name machine))))) machines)))))) -- cgit v1.2.3 From 53c594cb3f1f783fea18be6da23a863b00c14f5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 24 Mar 2020 16:56:19 +0100 Subject: pack: Do not store extended attributes in squashfs images. * guix/scripts/pack.scm (squashfs-image)[build](mksquashfs): Pass "-no-xattrs". --- guix/scripts/pack.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6829d7265f..b6fb73838d 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 . + "-no-xattrs" + ;; Set file times and the file system creation time to ;; one second after the Epoch. "-all-time" "1" "-mkfs-time" "1" -- cgit v1.2.3 From 637db76d7ad1af5323a6a6b87b8a6a2e6dfed754 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 24 Mar 2020 18:12:30 +0100 Subject: guix system: Fix mistaken 'guix pull' warning upon 'reconfigure'. Fixes . Reported by Florian Pelz . * guix/scripts/system.scm (maybe-suggest-running-guix-pull): Check whether 'current-profile' returns true instead of checking for the existence of ~root/.config/guix/current. That way, "sudo guix system reconfigure" no longer emits a warning in that case. --- guix/scripts/system.scm | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8d1938281a..61a3c95dbd 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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) @@ -718,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 - ;; 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 + ;; + (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!~%")))) -- cgit v1.2.3 From 57e12aad6dfc2d12567164144dd15161e66f32d5 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 15 Mar 2020 20:54:50 +0000 Subject: scripts: lint: Handle store connections for lint checkers. Rather than individual checkers opening up a connection to the store for each package to check, if any checker requires a store connection, open a connection and pass it to all checkers that would use it. This makes running the derivation checker much faster for multiple packages. * guix/scripts/lint.scm (run-checkers): Add a #:store argument, and pass the store to checkers if they require a store connection. (guix-lint): Establish a store connection if any checker requires one, and pass it through to run-checkers. --- guix/scripts/lint.scm | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) (limited to 'guix/scripts') 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)))))))) -- cgit v1.2.3 From 2d5ee2c6e886ef3b717954b80c2c54c47c1805d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 25 Mar 2020 14:55:08 +0100 Subject: archive: Use 'with-build-handler'. * guix/scripts/archive.scm (export-from-store): Remove call to 'show-what-to-build' and dry-run? condition. (guix-archive): Wrap 'cond' in 'with-build-handler'. --- guix/scripts/archive.scm | 50 ++++++++++++++++++++++++------------------------ 1 file changed, 25 insertions(+), 25 deletions(-) (limited to 'guix/scripts') 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~%"))))))))))))) -- cgit v1.2.3 From c74f19d758c786d30ee238e3bc8c4e3f8893ba4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 25 Mar 2020 15:01:15 +0100 Subject: environment: Use 'with-build-handler'. * guix/scripts/environment.scm (build-environment): Remove. (guix-environment): Wrap 'with-status-verbosity' in 'with-build-handler'. Remove 'dry-run?' conditional. Use 'built-derivations' instead of 'build-environment'. --- guix/scripts/environment.scm | 144 ++++++++++++++++++++----------------------- 1 file changed, 66 insertions(+), 78 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index f04363750e..ca12346815 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 -;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018 Mike Gerwitz ;;; ;;; This file is part of GNU Guix. @@ -364,19 +364,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." @@ -720,67 +707,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 - (canonical-package guile-2.2))))) - (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 + (canonical-package guile-2.2))))) + (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?))))))))))))))) -- cgit v1.2.3 From 260eae789369170cad76ac0ef94fe9ae5af44ce0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 26 Mar 2020 12:26:41 +0100 Subject: status: Display synthetic information about profiles being built. * guix/status.scm (print-build-event): Add 'profile case. * guix/scripts/package.scm (build-and-use-profile): Remove now redundant message. --- guix/scripts/package.scm | 4 ---- 1 file changed, 4 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b5d16acec0..110d4f2977 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -161,10 +161,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)))))) -- cgit v1.2.3