diff options
| author | Mathieu Othacehe <othacehe@gnu.org> | 2020-10-02 09:53:45 +0200 |
|---|---|---|
| committer | Mathieu Othacehe <othacehe@gnu.org> | 2020-10-02 10:03:29 +0200 |
| commit | bdbd8bf9054c88aaf694a08e49270c95e6adad27 (patch) | |
| tree | 135b1e5f4ea5a61a440aee026f52d47a151a2af6 /guix/scripts | |
| parent | cc346931523a7235a8093ec96f05412d5f2f468d (diff) | |
| download | guix-patches-bdbd8bf9054c88aaf694a08e49270c95e6adad27.tar guix-patches-bdbd8bf9054c88aaf694a08e49270c95e6adad27.tar.gz | |
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.
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/system.scm | 64 |
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." |