[bug#41785] [PATCH v3 2/2] services: Add 'hurd-vm service-type'.

[Mathieu Othacehe]

Hey!

> +(define (hurd-vm-disk-image config)
> +  "Return a disk-image for the Hurd according to CONFIG."
> +  (let ((os (hurd-vm-configuration-os config))
> +        (disk-size (hurd-vm-configuration-disk-size config))
> +        (target (and (not (%current-target-system)) "i586-pc-gnu"))
> +        (base-image (find-image "ext2" (%current-target-system))))
> +    (with-parameters ((%current-target-system target))
> +      (system-image
> +       (image (inherit base-image)
> +              (size disk-size)
> +              (operating-system os))))))

With the attached patch, you could write:

--8<---------------cut here---------------start------------->8---
(define (hurd-vm-disk-image config)
  "Return a disk-image for the Hurd according to CONFIG."
  (let ((os (hurd-vm-configuration-os config))
        (disk-size (hurd-vm-configuration-disk-size config)))
    (system-image
     (image
      (inherit hurd-disk-image)
      (size disk-size)
      (operating-system os)))))
--8<---------------cut here---------------end--------------->8---

WDYT?

Mathieu

>From dbcfd86a74903cb0fe77843518625436d749ed09 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Sat, 13 Jun 2020 14:01:18 +0200
Subject: [PATCH] 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 0a92d168e9..19b466527b 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 6c4573509d..7b45fdfea7 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -103,6 +103,7 @@
 (define hurd-disk-image
   (image
    (format 'disk-image)
+   (target "i586-pc-gnu")
    (partitions
     (list (partition
            (size 'guess)
@@ -518,6 +519,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."
@@ -529,32 +538,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)
   "Find and return an image that could match the given FILE-SYSTEM-TYPE.  This
@@ -572,4 +582,8 @@ record."
              (else
               efi-disk-image))))))))
 
+;;; Local Variables:
+;;; eval: (put 'maybe-with-target 'scheme-indent-function 1)
+;;; End:
+
 ;;; image.scm ends here
-- 
2.24.0