ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-12 14:16:55 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

scripts: system: Honor target argument.

Browse source 
Since 313f492657 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.
This commit is contained in:
Mathieu Othacehe 2020-10-02 09:53:45 +02:00
parent cc34693152
commit bdbd8bf905
No known key found for this signature in database
GPG key ID: 8354763531769CA6
1 changed files with 34 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

64
guix/scripts/system.scm
View file

@ -671,36 +671,40 @@ (define* (system-derivation-for-action os action
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."