me
/
guix
Archived
1
0
Fork 0
Code

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'.
master
Ludovic Courtès 2020-03-19 11:17:34 +01:00
parent 65ffb9388c
commit a0f480d623
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 41 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
guix/scripts/system.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
@ -403,7 +403,6 @@ STORE is an open connection to the store."
#:old-entries old-entries))) #:old-entries old-entries)))
(drvs -> (list bootcfg))) (drvs -> (list bootcfg)))
(mbegin %store-monad (mbegin %store-monad
(show-what-to-build* drvs)
(built-derivations drvs) (built-derivations drvs)
;; Only install bootloader configuration file. ;; Only install bootloader configuration file.
(install-bootloader local-eval bootloader-config bootcfg (install-bootloader local-eval bootloader-config bootcfg
@ -837,8 +836,7 @@ static checks."
(% (if derivations-only? (% (if derivations-only?
(return (for-each (compose println derivation-file-name) (return (for-each (compose println derivation-file-name)
drvs)) drvs))
(maybe-build drvs #:dry-run? dry-run? (built-derivations drvs))))
#:use-substitutes? use-substitutes?))))
(if (or dry-run? derivations-only?) (if (or dry-run? derivations-only?)
(return #f) (return #f)
@ -1139,42 +1137,46 @@ resulting from command-line parsing."
(with-store store (with-store store
(set-build-options-from-command-line store opts) (set-build-options-from-command-line store opts)
(run-with-store store (with-build-handler (build-notifier #:use-substitutes?
(mbegin %store-monad (assoc-ref opts 'substitutes?)
(set-guile-for-build (default-guile)) #:dry-run?
(case action (assoc-ref opts 'dry-run?))
((extension-graph) (run-with-store store
(export-extension-graph os (current-output-port))) (mbegin %store-monad
((shepherd-graph) (set-guile-for-build (default-guile))
(export-shepherd-graph os (current-output-port))) (case action
(else ((extension-graph)
(unless (memq action '(build init)) (export-extension-graph os (current-output-port)))
(warn-about-old-distro #:suggested-command ((shepherd-graph)
"guix system reconfigure")) (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 (perform-action action os
#:dry-run? dry? #:dry-run? dry?
#:derivations-only? (assoc-ref opts #:derivations-only? (assoc-ref opts
'derivations-only?) 'derivations-only?)
#:use-substitutes? (assoc-ref opts 'substitutes?) #:use-substitutes? (assoc-ref opts 'substitutes?)
#:skip-safety-checks? #:skip-safety-checks?
(assoc-ref opts 'skip-safety-checks?) (assoc-ref opts 'skip-safety-checks?)
#:file-system-type (assoc-ref opts 'file-system-type) #:file-system-type (assoc-ref opts 'file-system-type)
#:image-size (assoc-ref opts 'image-size) #:image-size (assoc-ref opts 'image-size)
#:full-boot? (assoc-ref opts 'full-boot?) #:full-boot? (assoc-ref opts 'full-boot?)
#:container-shared-network? #:container-shared-network?
(assoc-ref opts 'container-shared-network?) (assoc-ref opts 'container-shared-network?)
#:mappings (filter-map (match-lambda #:mappings (filter-map (match-lambda
(('file-system-mapping . m) (('file-system-mapping . m)
m) m)
(_ #f)) (_ #f))
opts) opts)
#:install-bootloader? bootloader? #:install-bootloader? bootloader?
#:target target-file #:target target-file
#:bootloader-target bootloader-target #:bootloader-target bootloader-target
#:gc-root (assoc-ref opts 'gc-root))))) #:gc-root (assoc-ref opts 'gc-root)))))
#:target target #:target target
#:system system)) #:system system)))
(warn-about-disk-space))) (warn-about-disk-space)))
(define (resolve-subcommand name) (define (resolve-subcommand name)