diff options
Diffstat (limited to 'gnu/system/image.scm')
| -rw-r--r-- | gnu/system/image.scm | 212 |
1 files changed, 130 insertions, 82 deletions
diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 571b7af5f3..1bda25fd7f 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +44,7 @@ #:use-module (gnu packages genimage) #:use-module (gnu packages guile) #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu packages hurd) #:use-module (gnu packages linux) #:use-module (gnu packages mtools) #:use-module ((srfi srfi-1) #:prefix srfi-1:) @@ -54,6 +56,7 @@ #:export (esp-partition root-partition + hurd-disk-image efi-disk-image iso9660-image @@ -65,9 +68,17 @@ ;;; Images definitions. ;;; +;; This is the offset before the first partition. GRUB will install itself in +;; this post-MBR gap. +(define root-offset (* 512 2048)) + +;; Generic root partition label. +(define root-label "Guix_image") + (define esp-partition (partition (size (* 40 (expt 2 20))) + (offset root-offset) (label "GNU-ESP") ;cosmetic only ;; Use "vfat" here since this property is used when mounting. The actual ;; FAT-ness is based on file system size (16 in this case). @@ -78,11 +89,32 @@ (define root-partition (partition (size 'guess) - (label "Guix_image") + (label root-label) (file-system "ext4") (flags '(boot)) (initializer (gexp initialize-root-partition)))) +(define hurd-initialize-root-partition + #~(lambda* (#:rest args) + (apply initialize-root-partition + (append args + (list #:make-device-nodes + make-hurd-device-nodes))))) + +(define hurd-disk-image + (image + (format 'disk-image) + (target "i586-pc-gnu") + (partitions + (list (partition + (size 'guess) + (offset root-offset) + (label root-label) + (file-system "ext2") + (file-system-options '("-o" "hurd" "-O" "ext_attr")) + (flags '(boot)) + (initializer hurd-initialize-root-partition)))))) + (define efi-disk-image (image (format 'disk-image) @@ -117,6 +149,7 @@ 'make-partition-image'." #~'(#$@(list (partition-size partition)) #$(partition-file-system partition) + #$(partition-file-system-options partition) #$(partition-label partition) #$(and=> (partition-uuid partition) uuid-bytevector))) @@ -136,16 +169,32 @@ (with-imported-modules `(,@(source-module-closure '((gnu build vm) (gnu build image) + (gnu build hurd-boot) + (gnu build linux-boot) (guix store database)) #:select? not-config?) ((guix config) => ,(make-config.scm))) #~(begin (use-modules (gnu build vm) (gnu build image) + (gnu build hurd-boot) + (gnu build linux-boot) (guix store database) (guix build utils)) gexp* ...)))) +(define (root-partition? partition) + "Return true if PARTITION is the root partition, false otherwise." + (member 'boot (partition-flags partition))) + +(define (find-root-partition image) + "Return the root partition of the given IMAGE." + (srfi-1:find root-partition? (image-partitions image))) + +(define (root-partition-index image) + "Return the index of the root partition of the given IMAGE." + (1+ (srfi-1:list-index root-partition? (image-partitions image)))) + ;; ;; Disk image. @@ -221,8 +270,11 @@ used in the image." #:references-graphs '#$graph #:deduplicate? #f #:system-directory #$os + #:grub-efi #+grub-efi #:bootloader-package - #$(bootloader-package bootloader) + #+(bootloader-package bootloader) + #:bootloader-installer + #+(bootloader-installer bootloader) #:bootcfg #$bootcfg #:bootcfg-location #$(bootloader-configuration-file bootloader))))) @@ -232,7 +284,7 @@ used in the image." (type (partition-file-system partition)) (image-builder (with-imported-modules* - (let ((inputs '#$(list e2fsprogs dosfstools mtools))) + (let ((inputs '#+(list e2fsprogs dosfstools mtools))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) (make-partition-image #$(partition->gexp partition) #$output @@ -243,11 +295,17 @@ used in the image." ;; Return the genimage partition configuration for PARTITION. (let ((label (partition-label partition)) (dos-type (partition->dos-type partition)) - (image (partition-image partition))) + (image (partition-image partition)) + (offset (partition-offset partition))) #~(format #f "~/partition ~a { - ~/~/partition-type = ~a - ~/~/image = \"~a\" - ~/}" #$label #$dos-type #$image))) +~/~/partition-type = ~a +~/~/image = \"~a\" +~/~/offset = \"~a\" +~/}" + #$label + #$dos-type + #$image + #$offset))) (let* ((format (image-format image)) (image-type (format->image-type format)) @@ -269,9 +327,17 @@ image ~a { (let* ((substitutable? (image-substitutable? image)) (builder (with-imported-modules* - (let ((inputs '#$(list genimage coreutils findutils))) + (let ((inputs '#+(list genimage coreutils findutils)) + (bootloader-installer + #+(bootloader-disk-image-installer bootloader))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (genimage #$(image->genimage-cfg image) #$output)))) + (genimage #$(image->genimage-cfg image) #$output) + ;; Install the bootloader directly on the disk-image. + (when bootloader-installer + (bootloader-installer + #+(bootloader-package bootloader) + #$(root-partition-index image) + (string-append #$output "/" #$genimage-name)))))) (image-dir (computed-file "image-dir" builder))) (computed-file name #~(symlink @@ -364,14 +430,6 @@ used in the image. " ;; Image creation. ;; -(define (root-partition? partition) - "Return true if PARTITION is the root partition, false otherwise." - (member 'boot (partition-flags partition))) - -(define (find-root-partition image) - "Return the root partition of the given IMAGE." - (srfi-1:find root-partition? (image-partitions image))) - (define (image->root-file-system image) "Return the IMAGE root partition file-system type." (let ((format (image-format image))) @@ -398,18 +456,18 @@ to OS. Also set the UUID and the size of the root partition." (string=? (file-system-mount-point fs) "/")) (operating-system-file-systems os))) - (let*-values (((partitions) (image-partitions base-image)) - ((root-partition other-partitions) - (srfi-1:partition root-partition? partitions))) - (image - (inherit base-image) - (operating-system os) - (partitions - (cons (partition - (inherit (car root-partition)) - (uuid (file-system-device root-file-system)) - (size (root-size base-image))) - other-partitions))))) + (image + (inherit base-image) + (operating-system os) + (partitions + (map (lambda (p) + (if (root-partition? p) + (partition + (inherit p) + (uuid (file-system-device root-file-system)) + (size (root-size base-image))) + p)) + (image-partitions base-image))))) (define (operating-system-for-image image) "Return an operating-system based on the one specified in IMAGE, but @@ -462,71 +520,61 @@ it can be used for bootloading." (type root-file-system-type)) file-systems-to-keep))))) -(define* (make-system-image image) +(define* (system-image image) "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660 image, depending on IMAGE format." (define substitutable? (image-substitutable? image)) (let* ((os (operating-system-for-image image)) (image* (image-with-os image os)) + (target (image-target image)) (register-closures? (has-guix-service-type? os)) (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)) - #:grub-mkrescue-environment - '(("MKRESCUE_SED_MODE" . "mbr_hfs"))))))) - -(define (find-image file-system-type) - "Find and return an image that could match the given FILE-SYSTEM-TYPE. This -is useful to adapt to interfaces written before the addition of the <image> -record." - ;; XXX: Add support for system and target here, or in the caller. + (with-parameters ((%current-target-system target)) + (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, +built for TARGET. This is useful to adapt to interfaces written before the +addition of the <image> record." (match file-system-type ("iso9660" iso9660-image) - (_ efi-disk-image))) - -(define (system-image image) - "Wrap 'make-system-image' call, so that it is used only if the given IMAGE -is supported. Otherwise, fallback to image creation in a VM. This is -temporary and should be removed once 'make-system-image' is able to deal with -all types of images." - (define substitutable? (image-substitutable? image)) - (define volatile-root? (image-volatile-root? image)) + (_ (cond + ((and target + (hurd-triplet? target)) + hurd-disk-image) + (else + efi-disk-image))))) - (let* ((image-os (image-operating-system image)) - (image-root-filesystem-type (image->root-file-system image)) - (bootloader (bootloader-configuration-bootloader - (operating-system-bootloader image-os))) - (bootloader-name (bootloader-name bootloader)) - (size (image-size image)) - (format (image-format image))) - (mbegin %store-monad - (if (and (or (eq? bootloader-name 'grub) - (eq? bootloader-name 'extlinux)) - (eq? format 'disk-image)) - ;; Fallback to image creation in a VM when it is not yet supported - ;; by this module. - (system-disk-image-in-vm image-os - #:disk-image-size size - #:file-system-type image-root-filesystem-type - #:volatile? volatile-root? - #:substitutable? substitutable?) - (lower-object - (make-system-image image)))))) +;;; Local Variables: +;;; eval: (put 'maybe-with-target 'scheme-indent-function 1) +;;; End: ;;; image.scm ends here |