aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMathieu Othacehe <othacehe@gnu.org>2020-10-02 09:53:45 +0200
committerMathieu Othacehe <othacehe@gnu.org>2020-10-02 10:03:29 +0200
commitbdbd8bf9054c88aaf694a08e49270c95e6adad27 (patch)
tree135b1e5f4ea5a61a440aee026f52d47a151a2af6
parentcc346931523a7235a8093ec96f05412d5f2f468d (diff)
downloadguix-bdbd8bf9054c88aaf694a08e49270c95e6adad27.tar.gz
guix-bdbd8bf9054c88aaf694a08e49270c95e6adad27.zip
scripts: system: Honor target argument.
Since 313f492657f1d0863c641fa5ee7f5b7028e27c94 the target argument passed to "guix system" was not honored for 'disk-image' command. This forces the command line passed "target" to take precedence over the "target" field of the <image> record returned by "os->image" procedure. * guix/scripts/system.scm (system-derivation-for-action): Override the "target" field of the "image" record using the "target" argument from the command line.
-rw-r--r--guix/scripts/system.scm64
1 files changed, 34 insertions, 30 deletions
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 7b3eacf2e1..939559e719 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -671,36 +671,40 @@ checking this by themselves in their 'check' procedure."
full-boot? container-shared-network?
mappings label)
"Return as a monadic value the derivation for OS according to ACTION."
- (case action
- ((build init reconfigure)
- (operating-system-derivation os))
- ((container)
- (container-script
- os
- #:mappings mappings
- #:shared-network? container-shared-network?))
- ((vm-image)
- (system-qemu-image os #:disk-image-size image-size))
- ((vm)
- (system-qemu-image/shared-store-script os
- #:full-boot? full-boot?
- #:disk-image-size
- (if full-boot?
- image-size
- (* 70 (expt 2 20)))
- #:mappings mappings))
- ((disk-image)
- (let ((base-image (os->image os #:type image-type)))
- (lower-object
- (system-image
- (image
- (inherit (if label
- (image-with-label base-image label)
- base-image))
- (size image-size)
- (operating-system os))))))
- ((docker-image)
- (system-docker-image os #:shared-network? container-shared-network?))))
+ (mlet %store-monad ((target (current-target-system)))
+ (case action
+ ((build init reconfigure)
+ (operating-system-derivation os))
+ ((container)
+ (container-script
+ os
+ #:mappings mappings
+ #:shared-network? container-shared-network?))
+ ((vm-image)
+ (system-qemu-image os #:disk-image-size image-size))
+ ((vm)
+ (system-qemu-image/shared-store-script os
+ #:full-boot? full-boot?
+ #:disk-image-size
+ (if full-boot?
+ image-size
+ (* 70 (expt 2 20)))
+ #:mappings mappings))
+ ((disk-image)
+ (let* ((base-image (os->image os #:type image-type))
+ (base-target (image-target base-image)))
+ (lower-object
+ (system-image
+ (image
+ (inherit (if label
+ (image-with-label base-image label)
+ base-image))
+ (target (or base-target target))
+ (size image-size)
+ (operating-system os))))))
+ ((docker-image)
+ (system-docker-image os
+ #:shared-network? container-shared-network?)))))
(define (maybe-suggest-running-guix-pull)
"Suggest running 'guix pull' if this has never been done before."