From: Mathieu Othacehe <othacehe@gnu.org>
To: "Jan \(janneke\) Nieuwenhuizen" <janneke@gnu.org>
Cc: 41785@debbugs.gnu.org, "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#41785] [PATCH v3 2/2] services: Add 'hurd-vm service-type'.
Date: Sat, 13 Jun 2020 14:49:23 +0200 [thread overview]
Message-ID: <87imfvjfl8.fsf@gnu.org> (raw)
In-Reply-To: <20200612214214.14112-2-janneke@gnu.org> (Jan Nieuwenhuizen's message of "Fri, 12 Jun 2020 23:42:14 +0200")
[-- Attachment #1: Type: text/plain, Size: 1071 bytes --]
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-image-Add-target-support.patch --]
[-- Type: text/x-diff, Size: 4960 bytes --]
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
next prev parent reply other threads:[~2020-06-13 12:50 UTC|newest]
Thread overview: 35+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-06-10 8:54 [bug#41785] [PATCH] DRAFT services: Add 'hurd-in-vm service-type' Jan (janneke) Nieuwenhuizen
2020-06-10 11:34 ` Mathieu Othacehe
2020-06-11 19:43 ` Ludovic Courtès
2020-06-11 19:59 ` Jan Nieuwenhuizen
2020-06-11 20:01 ` Marius Bakke
2020-06-12 6:39 ` Jan Nieuwenhuizen
2020-06-12 10:51 ` Diego Nicola Barbato
2020-06-13 7:30 ` Jan Nieuwenhuizen
2020-06-11 19:59 ` Ludovic Courtès
2020-06-11 21:57 ` Jan Nieuwenhuizen
2020-06-12 6:46 ` Jan Nieuwenhuizen
2020-06-12 14:45 ` Ludovic Courtès
2020-06-12 21:33 ` Jan Nieuwenhuizen
2020-06-12 15:04 ` Mathieu Othacehe
2020-06-12 21:33 ` Jan Nieuwenhuizen
2020-06-14 12:10 ` [bug#41785] [PATCH v4] " Jan Nieuwenhuizen
2020-06-14 12:44 ` Mathieu Othacehe
2020-06-14 13:18 ` Jan Nieuwenhuizen
2020-06-14 15:52 ` Mathieu Othacehe
2020-06-14 16:22 ` Mathieu Othacehe
2020-06-14 16:42 ` bug#41785: " Jan Nieuwenhuizen
2020-06-12 14:42 ` [bug#41785] [PATCH] DRAFT " Mathieu Othacehe
2020-06-12 15:39 ` Ludovic Courtès
2020-06-12 21:42 ` [bug#41785] [PATCH v3 1/2] image: Make 'find-image' non-monadic Jan (janneke) Nieuwenhuizen
2020-06-12 21:42 ` [bug#41785] [PATCH v3 2/2] services: Add 'hurd-vm service-type' Jan (janneke) Nieuwenhuizen
2020-06-13 12:49 ` Mathieu Othacehe [this message]
2020-06-13 13:10 ` Jan Nieuwenhuizen
2020-06-13 14:35 ` Ludovic Courtès
2020-06-13 15:01 ` Mathieu Othacehe
2020-06-13 10:56 ` [bug#41785] [PATCH v3 1/2] image: Make 'find-image' non-monadic Mathieu Othacehe
2020-06-13 13:05 ` Jan Nieuwenhuizen
2020-06-14 12:37 ` Mathieu Othacehe
2020-06-14 13:12 ` Jan Nieuwenhuizen
2020-06-14 13:32 ` Jan Nieuwenhuizen
2020-06-14 15:44 ` Mathieu Othacehe
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87imfvjfl8.fsf@gnu.org \
--to=othacehe@gnu.org \
--cc=41785@debbugs.gnu.org \
--cc=janneke@gnu.org \
--cc=ludo@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).