;;; 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.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system image)
+ #:use-module (guix diagnostics)
+ #:use-module (guix discovery)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix monads)
#: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 (gnu packages virtualization)
#:use-module ((srfi srfi-1) #:prefix srfi-1:)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
- #:export (esp-partition
+ #:export (root-offset
+ root-label
+
+ esp-partition
root-partition
efi-disk-image
iso9660-image
- find-image
- system-image))
+ image-with-os
+ raw-image-type
+ qcow2-image-type
+ iso-image-type
+ uncompressed-iso-image-type
+
+ image-with-label
+ system-image
+
+ %image-types
+ lookup-image-type-by-name))
\f
;;;
;;; 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).
(define root-partition
(partition
(size 'guess)
- (label "Guix_image")
+ (label root-label)
(file-system "ext4")
(flags '(boot))
(initializer (gexp initialize-root-partition))))
(list (partition
(size 'guess)
(label "GUIX_IMAGE")
- (flags '(boot)))))
- ;; XXX: Temporarily disable compression to speed-up the tests.
- (compression? #f)))
+ (flags '(boot)))))))
+
+\f
+;;;
+;;; Images types.
+;;;
+
+(define-syntax-rule (image-with-os base-image os)
+ "Return an image inheriting from BASE-IMAGE, with the operating-system field
+set to the given OS."
+ (image
+ (inherit base-image)
+ (operating-system os)))
+
+(define raw-image-type
+ (image-type
+ (name 'raw)
+ (constructor (cut image-with-os efi-disk-image <>))))
+
+(define qcow2-image-type
+ (image-type
+ (name 'qcow2)
+ (constructor (cut image-with-os
+ (image
+ (inherit efi-disk-image)
+ (name 'image.qcow2)
+ (format 'compressed-qcow2))
+ <>))))
+
+(define iso-image-type
+ (image-type
+ (name 'iso9660)
+ (constructor (cut image-with-os iso9660-image <>))))
+
+(define uncompressed-iso-image-type
+ (image-type
+ (name 'uncompressed-iso9660)
+ (constructor (cut image-with-os
+ (image
+ (inherit iso9660-image)
+ (compression? #f))
+ <>))))
\f
;;
'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)))
(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))))
+
\f
;;
;; Disk image.
(define (format->image-type format)
;; Return the genimage format corresponding to FORMAT. For now, only
;; the hdimage format (raw disk-image) is supported.
- (case format
- ((disk-image) "hdimage")
+ (cond
+ ((memq format '(disk-image compressed-qcow2)) "hdimage")
(else
(raise (condition
(&message
(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
+ #: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)))))
- (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.
(image (partition-image partition))
(offset (partition-offset partition)))
#~(format #f "~/partition ~a {
- ~/~/partition-type = ~a
- ~/~/image = \"~a\"
- ~/~/offset = \"~a\"
- ~/}"
+~/~/partition-type = ~a
+~/~/image = \"~a\"
+~/~/offset = \"~a\"
+~/}"
#$label
#$dos-type
#$image
- #$(or offset 0))))
+ #$offset)))
(let* ((format (image-format image))
(image-type (format->image-type format))
}~%" #$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))
+ (format (image-format image))
+ (substitutable? (image-substitutable? image))
(builder
(with-imported-modules*
- (let ((inputs '#$(list genimage coreutils findutils)))
+ (let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
+ (bootloader-installer
+ #+(bootloader-disk-image-installer bootloader))
+ (out-image (string-append "images/" #$genimage-name)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (genimage #$(image->genimage-cfg image) #$output))))
- (image-dir (computed-file "image-dir" builder)))
- (computed-file name
- #~(symlink
- (string-append #$image-dir "/" #$genimage-name)
- #$output)
+ (genimage #$(image->genimage-cfg image))
+ ;; Install the bootloader directly on the disk-image.
+ (when bootloader-installer
+ (bootloader-installer
+ #+(bootloader-package bootloader)
+ #$(root-partition-index image)
+ out-image))
+ (convert-disk-image out-image '#$format #$output)))))
+ (computed-file name builder
#:options `(#:substitutable? ,substitutable?))))
\f
(define* (system-iso9660-image image
#:key
- (name "iso9660-image")
+ (name "image.iso")
bootcfg
bootloader
register-closures?
(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?
#:options `(#:references-graphs ,inputs
#:substitutable? ,substitutable?))))
+(define (image-with-label base-image label)
+ "The volume ID of an ISO is the label of the first partition. This procedure
+returns an image record where the first partition's label is set to <label>."
+ (image
+ (inherit base-image)
+ (partitions
+ (match (image-partitions base-image)
+ ((boot others ...)
+ (cons
+ (partition
+ (inherit boot)
+ (label label))
+ others))))))
+
\f
;;
;; 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)))
image-size)
(else root-size))))
-(define* (image-with-os base-image os)
+(define* (image-with-os* base-image os)
"Return an image based on BASE-IMAGE but with the operating-system field set
to OS. Also set the UUID and the size of the root partition."
(define root-file-system
(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
(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))
+ (define target (image-target image))
+
+ (with-parameters ((%current-target-system target))
+ (let* ((os (operating-system-for-image image))
+ (image* (image-with-os* image os))
+ (image-format (image-format image))
+ (register-closures? (has-guix-service-type? os))
+ (bootcfg (operating-system-bootcfg os))
+ (bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os))))
+ (cond
+ ((memq image-format '(disk-image compressed-qcow2))
+ (system-disk-image image*
+ #:bootcfg bootcfg
+ #:bootloader bootloader
+ #:register-closures? register-closures?
+ #:inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg))))
+ ((memq image-format '(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"))))))))
- (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."
- ;; XXX: Add support for system and target here, or in the caller.
- (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))
+\f
+;;
+;; Image detection.
+;;
- (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))))))
+(define (image-modules)
+ "Return the list of image modules."
+ (cons (resolve-interface '(gnu system image))
+ (all-modules (map (lambda (entry)
+ `(,entry . "gnu/system/images/"))
+ %load-path)
+ #:warn warn-about-load-error)))
+
+(define %image-types
+ ;; The list of publically-known image types.
+ (delay (fold-module-public-variables (lambda (obj result)
+ (if (image-type? obj)
+ (cons obj result)
+ result))
+ '()
+ (image-modules))))
+
+(define (lookup-image-type-by-name name)
+ "Return the image type called NAME."
+ (or (srfi-1:find (lambda (image-type)
+ (eq? name (image-type-name image-type)))
+ (force %image-types))
+ (raise
+ (formatted-message (G_ "~a: no such image type~%") name))))
;;; image.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff