01/02: image: Add 'target' support.

[guix-commits]

mothacehe pushed a commit to branch master
in repository guix.

commit f292d4719dead6a615187f325fbc0bb0e99d10b4
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sat Jun 13 14:01:18 2020 +0200

    image: Add 'target' support.
    
    * gnu/image.scm (<image>)[target]: New field,
    (image-target): new public method.
    * gnu/system/image.scm (hurd-disk-image): Set "i586-pc-gnu" as image 
'target'
    field,
    (maybe-with-target): new procedure,
    (system-image): honor image 'target' field using the above procedure.
---
 gnu/image.scm        |  3 +++
 gnu/system/image.scm | 66 +++++++++++++++++++++++++++++++---------------------
 2 files changed, 43 insertions(+), 26 deletions(-)

diff --git a/gnu/image.scm b/gnu/image.scm
index 0a92d16..19b4665 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -33,6 +33,7 @@
             image
             image-name
             image-format
+            image-target
             image-size
             image-operating-system
             image-partitions
@@ -67,6 +68,8 @@
   image make-image
   image?
   (format             image-format) ;symbol
+  (target             image-target
+                      (default #f))
   (size               image-size  ;size in bytes as integer
                       (default 'guess))
   (operating-system   image-operating-system  ;<operating-system>
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index be8b6e6..97e4bb0 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -104,6 +104,7 @@
 (define hurd-disk-image
   (image
    (format 'disk-image)
+   (target "i586-pc-gnu")
    (partitions
     (list (partition
            (size 'guess)
@@ -519,6 +520,14 @@ it can be used for bootloading."
                             (type root-file-system-type))
                           file-systems-to-keep)))))
 
+(define-syntax-rule (maybe-with-target image exp ...)
+  (let ((target (image-target image)))
+    (if target
+        (with-parameters ((%current-target-system target))
+          exp ...)
+        (begin
+          exp ...))))
+
 (define* (system-image image)
   "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
 image, depending on IMAGE format."
@@ -530,32 +539,33 @@ image, depending on IMAGE format."
          (bootcfg (operating-system-bootcfg os))
          (bootloader (bootloader-configuration-bootloader
                       (operating-system-bootloader os))))
-    (case (image-format image)
-      ((disk-image)
-       (system-disk-image image*
-                          #:bootcfg bootcfg
-                          #:bootloader bootloader
-                          #:register-closures? register-closures?
-                          #:inputs `(("system" ,os)
-                                     ("bootcfg" ,bootcfg))))
-      ((iso9660)
-       (system-iso9660-image
-        image*
-        #:bootcfg bootcfg
-        #:bootloader bootloader
-        #:register-closures? register-closures?
-        #:inputs `(("system" ,os)
-                   ("bootcfg" ,bootcfg))
-        ;; Make sure to use a mode that does no imply
-        ;; HFS+ tree creation that may fail with:
-        ;;
-        ;; "libisofs: FAILURE : Too much files to mangle,
-        ;; cannot guarantee unique file names"
-        ;;
-        ;; This happens if some limits are exceeded, see:
-        ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
-        #:grub-mkrescue-environment
-        '(("MKRESCUE_SED_MODE" . "mbr_only")))))))
+    (maybe-with-target image
+      (case (image-format image)
+        ((disk-image)
+         (system-disk-image image*
+                            #:bootcfg bootcfg
+                            #:bootloader bootloader
+                            #:register-closures? register-closures?
+                            #:inputs `(("system" ,os)
+                                       ("bootcfg" ,bootcfg))))
+        ((iso9660)
+         (system-iso9660-image
+          image*
+          #:bootcfg bootcfg
+          #:bootloader bootloader
+          #:register-closures? register-closures?
+          #:inputs `(("system" ,os)
+                     ("bootcfg" ,bootcfg))
+          ;; Make sure to use a mode that does no imply
+          ;; HFS+ tree creation that may fail with:
+          ;;
+          ;; "libisofs: FAILURE : Too much files to mangle,
+          ;; cannot guarantee unique file names"
+          ;;
+          ;; This happens if some limits are exceeded, see:
+          ;; 
https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
+          #:grub-mkrescue-environment
+          '(("MKRESCUE_SED_MODE" . "mbr_only"))))))))
 
 (define (find-image file-system-type target)
   "Find and return an image built that could match the given FILE-SYSTEM-TYPE,
@@ -570,4 +580,8 @@ addition of the <image> record."
         (else
          efi-disk-image)))))
 
+;;; Local Variables:
+;;; eval: (put 'maybe-with-target 'scheme-indent-function 1)
+;;; End:
+
 ;;; image.scm ends here