;;; 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.
;;;
#: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:)
#:use-module (srfi srfi-35)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
- #:export (esp-partition
+ #:export (root-offset
+ root-label
+
+ esp-partition
root-partition
efi-disk-image
(list (partition
(size 'guess)
(label "GUIX_IMAGE")
- (flags '(boot)))))
- ;; XXX: Temporarily disable compression to speed-up the tests.
- (compression? #f)))
+ (flags '(boot)))))))
\f
;;
(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* ...))))
(graph (match inputs
(((names . _) ...)
names)))
- (root-builder
+ (type (partition-file-system partition))
+ (image-builder
(with-imported-modules*
- (let* ((initializer #$(partition-initializer partition)))
+ (let ((initializer #$(partition-initializer partition))
+ (inputs '#+(list e2fsprogs fakeroot dosfstools mtools))
+ (image-root "tmp-root"))
(sql-schema #$schema)
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
;; decoded.
(setenv "GUIX_LOCPATH"
#+(file-append glibc-utf8-locales "/lib/locale"))
(setlocale LC_ALL "en_US.utf8")
- (initializer #$output
+ (initializer image-root
#:references-graphs '#$graph
#:deduplicate? #f
#:system-directory #$os
#+(bootloader-installer bootloader)
#:bootcfg #$bootcfg
#:bootcfg-location
- #$(bootloader-configuration-file bootloader)))))
- (image-root
- (computed-file "partition-image-root" root-builder
- #:options `(#:references-graphs ,inputs)))
- (type (partition-file-system partition))
- (image-builder
- (with-imported-modules*
- (let ((inputs '#+(list e2fsprogs dosfstools mtools)))
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ #$(bootloader-configuration-file bootloader))
(make-partition-image #$(partition->gexp partition)
#$output
- #$image-root)))))
- (computed-file "partition.img" image-builder)))
+ image-root)))))
+ (computed-file "partition.img" image-builder
+ #:options `(#:references-graphs ,inputs))))
(define (partition->config partition)
;; Return the genimage partition configuration for PARTITION.
}~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
(computed-file "genimage.cfg" builder)))
- (let* ((substitutable? (image-substitutable? image))
+ (let* ((image-name (image-name image))
+ (name (if image-name
+ (symbol->string image-name)
+ name))
+ (substitutable? (image-substitutable? image))
(builder
(with-imported-modules*
(let ((inputs '#+(list genimage coreutils findutils))
(graph (match inputs
(((names . _) ...)
names)))
- (root-builder
- (with-imported-modules*
- (sql-schema #$schema)
-
- ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8")
-
- (initialize-root-partition #$output
- #:references-graphs '#$graph
- #:deduplicate? #f
- #:system-directory #$os)))
- (image-root
- (computed-file "image-root" root-builder
- #:options `(#:references-graphs ,inputs)))
(builder
(with-imported-modules*
(let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
- sed grep coreutils findutils gawk)))
+ sed grep coreutils findutils gawk))
+ (image-root "tmp-root"))
+ (sql-schema #$schema)
+
+ ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+
+ (setlocale LC_ALL "en_US.utf8")
+
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
+ (initialize-root-partition image-root
+ #:references-graphs '#$graph
+ #:deduplicate? #f
+ #:system-directory #$os)
(make-iso9660-image #$xorriso
'#$grub-mkrescue-environment
#$bootloader
#$bootcfg
#$os
- #$image-root
+ image-root
#$output
#:references-graphs '#$graph
#:register-closures? #$register-closures?
"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))
- (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."
- (mbegin %store-monad
- (return
- (match file-system-type
- ("iso9660" iso9660-image)
- (_ efi-disk-image)))))
+ (define target (image-target image))
+
+ (with-parameters ((%current-target-system target))
+ (let* ((os (operating-system-for-image image))
+ (image* (image-with-os image os))
+ (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))
+ ;; 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)
+ (_ (cond
+ ((and target
+ (hurd-triplet? target))
+ (module-ref (resolve-interface '(gnu system images hurd))
+ 'hurd-disk-image))
+ (else
+ efi-disk-image)))))
;;; image.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff