summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2020-05-05 20:43:21 +0200
committerMarius Bakke <mbakke@fastmail.com>2020-05-05 20:43:21 +0200
commit87a40d7203a813921b3ef0805c2b46c0026d6c31 (patch)
treecebad70c1df30969005c18c4d9faa39d7d80cbf6 /gnu/system
parentba151b7e1a9cc0baf932b5c5e0c916e54d2e27f4 (diff)
parent751d1f01e4f0607d41e4c859d944753b18466652 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/image.scm532
-rw-r--r--gnu/system/install.scm1
-rw-r--r--gnu/system/linux-initrd.scm3
-rw-r--r--gnu/system/vm.scm216
4 files changed, 561 insertions, 191 deletions
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
new file mode 100644
index 0000000000..571b7af5f3
--- /dev/null
+++ b/gnu/system/image.scm
@@ -0,0 +1,532 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system image)
+ #:use-module (guix gexp)
+ #:use-module (guix modules)
+ #:use-module (guix monads)
+ #:use-module (guix records)
+ #:use-module (guix store)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module ((guix self) #:select (make-config.scm))
+ #:use-module (gnu bootloader)
+ #:use-module (gnu bootloader grub)
+ #:use-module (gnu image)
+ #:use-module (gnu services)
+ #:use-module (gnu services base)
+ #:use-module (gnu system)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system uuid)
+ #:use-module (gnu system vm)
+ #:use-module (guix packages)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages bootloaders)
+ #:use-module (gnu packages cdrom)
+ #:use-module (gnu packages disk)
+ #:use-module (gnu packages gawk)
+ #:use-module (gnu packages genimage)
+ #:use-module (gnu packages guile)
+ #:autoload (gnu packages gnupg) (guile-gcrypt)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages mtools)
+ #: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 match)
+ #:export (esp-partition
+ root-partition
+
+ efi-disk-image
+ iso9660-image
+
+ find-image
+ system-image))
+
+
+;;;
+;;; Images definitions.
+;;;
+
+(define esp-partition
+ (partition
+ (size (* 40 (expt 2 20)))
+ (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).
+ (file-system "vfat")
+ (flags '(esp))
+ (initializer (gexp initialize-efi-partition))))
+
+(define root-partition
+ (partition
+ (size 'guess)
+ (label "Guix_image")
+ (file-system "ext4")
+ (flags '(boot))
+ (initializer (gexp initialize-root-partition))))
+
+(define efi-disk-image
+ (image
+ (format 'disk-image)
+ (partitions (list esp-partition root-partition))))
+
+(define iso9660-image
+ (image
+ (format 'iso9660)
+ (partitions
+ (list (partition
+ (size 'guess)
+ (label "GUIX_IMAGE")
+ (flags '(boot)))))
+ ;; XXX: Temporarily disable compression to speed-up the tests.
+ (compression? #f)))
+
+
+;;
+;; Helpers.
+;;
+
+(define not-config?
+ ;; Select (guix …) and (gnu …) modules, except (guix config).
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix rest ...) #t)
+ (('gnu rest ...) #t)
+ (rest #f)))
+
+(define (partition->gexp partition)
+ "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for
+'make-partition-image'."
+ #~'(#$@(list (partition-size partition))
+ #$(partition-file-system partition)
+ #$(partition-label partition)
+ #$(and=> (partition-uuid partition)
+ uuid-bytevector)))
+
+(define gcrypt-sqlite3&co
+ ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
+ (srfi-1:append-map
+ (lambda (package)
+ (cons package
+ (match (package-transitive-propagated-inputs package)
+ (((labels packages) ...)
+ packages))))
+ (list guile-gcrypt guile-sqlite3)))
+
+(define-syntax-rule (with-imported-modules* gexp* ...)
+ (with-extensions gcrypt-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure
+ '((gnu build vm)
+ (gnu build image)
+ (guix store database))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (gnu build vm)
+ (gnu build image)
+ (guix store database)
+ (guix build utils))
+ gexp* ...))))
+
+
+;;
+;; Disk image.
+;;
+
+(define* (system-disk-image image
+ #:key
+ (name "disk-image")
+ bootcfg
+ bootloader
+ register-closures?
+ (inputs '()))
+ "Return as a file-like object, the disk-image described by IMAGE. Said
+image can be copied on a USB stick as is. BOOTLOADER is the bootloader that
+will be installed and configured according to BOOTCFG parameter.
+
+Raw images of the IMAGE partitions are first created. Then, genimage is used
+to assemble the partition images into a disk-image without resorting to a
+virtual machine.
+
+INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is
+true, register INPUTS in the store database of the image so that Guix can be
+used in the image."
+
+ (define genimage-name "image")
+
+ (define (image->genimage-cfg image)
+ ;; Return as a file-like object, the genimage configuration file
+ ;; describing the given 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")
+ (else
+ (raise (condition
+ (&message
+ (message
+ (format #f (G_ "Unsupported image type ~a~%.") format))))))))
+
+ (define (partition->dos-type partition)
+ ;; Return the MBR partition type corresponding to the given PARTITION.
+ ;; See: https://en.wikipedia.org/wiki/Partition_type.
+ (let ((flags (partition-flags partition)))
+ (cond
+ ((member 'esp flags) "0xEF")
+ (else "0x83"))))
+
+ (define (partition-image partition)
+ ;; Return as a file-like object, an image of the given PARTITION. A
+ ;; directory, filled by calling the PARTITION initializer procedure, is
+ ;; first created within the store. Then, an image of this directory is
+ ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the
+ ;; partition file-system type.
+ (let* ((os (image-operating-system image))
+ (schema (local-file (search-path %load-path
+ "guix/store/schema.sql")))
+ (graph (match inputs
+ (((names . _) ...)
+ names)))
+ (root-builder
+ (with-imported-modules*
+ (let* ((initializer #$(partition-initializer partition)))
+ (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")
+
+ (initializer #$output
+ #:references-graphs '#$graph
+ #:deduplicate? #f
+ #:system-directory #$os
+ #:bootloader-package
+ #$(bootloader-package 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)
+ (make-partition-image #$(partition->gexp partition)
+ #$output
+ #$image-root)))))
+ (computed-file "partition.img" image-builder)))
+
+ (define (partition->config partition)
+ ;; Return the genimage partition configuration for PARTITION.
+ (let ((label (partition-label partition))
+ (dos-type (partition->dos-type partition))
+ (image (partition-image partition)))
+ #~(format #f "~/partition ~a {
+ ~/~/partition-type = ~a
+ ~/~/image = \"~a\"
+ ~/}" #$label #$dos-type #$image)))
+
+ (let* ((format (image-format image))
+ (image-type (format->image-type format))
+ (partitions (image-partitions image))
+ (partitions-config (map partition->config partitions))
+ (builder
+ #~(begin
+ (let ((format (@ (ice-9 format) format)))
+ (call-with-output-file #$output
+ (lambda (port)
+ (format port
+ "\
+image ~a {
+~/~a {}
+~{~a~^~%~}
+}~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
+ (computed-file "genimage.cfg" builder)))
+
+ (let* ((substitutable? (image-substitutable? image))
+ (builder
+ (with-imported-modules*
+ (let ((inputs '#$(list genimage coreutils findutils)))
+ (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)
+ #:options `(#:substitutable? ,substitutable?))))
+
+
+;;
+;; ISO9660 image.
+;;
+
+(define (has-guix-service-type? os)
+ "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
+ (not (not (srfi-1:find (lambda (service)
+ (eq? (service-kind service) guix-service-type))
+ (operating-system-services os)))))
+
+(define* (system-iso9660-image image
+ #:key
+ (name "iso9660-image")
+ bootcfg
+ bootloader
+ register-closures?
+ (inputs '())
+ (grub-mkrescue-environment '()))
+ "Return as a file-like object a bootable, stand-alone iso9660 image.
+
+INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is
+true, register INPUTS in the store database of the image so that Guix can be
+used in the image. "
+ (define root-label
+ (match (image-partitions image)
+ ((partition)
+ (partition-label partition))))
+
+ (define root-uuid
+ (match (image-partitions image)
+ ((partition)
+ (uuid-bytevector (partition-uuid partition)))))
+
+ (let* ((os (image-operating-system image))
+ (bootloader (bootloader-package bootloader))
+ (compression? (image-compression? image))
+ (substitutable? (image-substitutable? image))
+ (schema (local-file (search-path %load-path
+ "guix/store/schema.sql")))
+ (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)))
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (make-iso9660-image #$xorriso
+ '#$grub-mkrescue-environment
+ #$bootloader
+ #$bootcfg
+ #$os
+ #$image-root
+ #$output
+ #:references-graphs '#$graph
+ #:register-closures? #$register-closures?
+ #:compression? #$compression?
+ #:volume-id #$root-label
+ #:volume-uuid #$root-uuid)))))
+ (computed-file name builder
+ #:options `(#:references-graphs ,inputs
+ #:substitutable? ,substitutable?))))
+
+
+;;
+;; 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)))
+ (if (eq? format 'iso9660)
+ "iso9660"
+ (partition-file-system (find-root-partition image)))))
+
+(define (root-size image)
+ "Return the root partition size of IMAGE."
+ (let* ((image-size (image-size image))
+ (root-partition (find-root-partition image))
+ (root-size (partition-size root-partition)))
+ (cond
+ ((and (eq? root-size 'guess) image-size)
+ image-size)
+ (else root-size))))
+
+(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
+ (srfi-1:find
+ (lambda (fs)
+ (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)))))
+
+(define (operating-system-for-image image)
+ "Return an operating-system based on the one specified in IMAGE, but
+suitable for image creation. Assign an UUID to the root file-system, so that
+it can be used for bootloading."
+ (define volatile-root? (image-volatile-root? image))
+
+ (define (root-uuid os)
+ ;; UUID of the root file system, computed in a deterministic fashion.
+ ;; This is what we use to locate the root file system so it has to be
+ ;; different from the user's own file system UUIDs.
+ (let ((type (if (eq? (image-format image) 'iso9660)
+ 'iso9660
+ 'dce)))
+ (operating-system-uuid os type)))
+
+ (let* ((root-file-system-type (image->root-file-system image))
+ (base-os (image-operating-system image))
+ (file-systems-to-keep
+ (srfi-1:remove
+ (lambda (fs)
+ (string=? (file-system-mount-point fs) "/"))
+ (operating-system-file-systems base-os)))
+ (format (image-format image))
+ (os
+ (operating-system
+ (inherit base-os)
+ (initrd (lambda (file-systems . rest)
+ (apply (operating-system-initrd base-os)
+ file-systems
+ #:volatile-root? volatile-root?
+ rest)))
+ (bootloader (if (eq? format 'iso9660)
+ (bootloader-configuration
+ (inherit
+ (operating-system-bootloader base-os))
+ (bootloader grub-mkrescue-bootloader))
+ (operating-system-bootloader base-os)))
+ (file-systems (cons (file-system
+ (mount-point "/")
+ (device "/dev/placeholder")
+ (type root-file-system-type))
+ file-systems-to-keep))))
+ (uuid (root-uuid os)))
+ (operating-system
+ (inherit os)
+ (file-systems (cons (file-system
+ (mount-point "/")
+ (device uuid)
+ (type root-file-system-type))
+ file-systems-to-keep)))))
+
+(define* (make-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))
+ (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))
+
+ (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))))))
+
+;;; image.scm ends here
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 7166c12bcc..fe49ffdb94 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -523,6 +523,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
mdadm
dosfstools ;mkfs.fat, for the UEFI boot partition
btrfs-progs
+ f2fs-tools
jfsutils
openssh ;we already have sshd, having ssh/scp can help
wireless-tools iw wpa-supplicant-minimal iproute
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index d84f352663..c43d53a210 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -245,6 +245,9 @@ FILE-SYSTEMS."
'())
,@(if (find (file-system-type-predicate "jfs") file-systems)
(list jfs_fsck/static)
+ '())
+ ,@(if (find (file-system-type-predicate "f2fs") file-systems)
+ (list f2fs-fsck/static)
'())))
(define-syntax vhash ;TODO: factorize
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 1d5ee39497..4ea82cfd50 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -77,7 +77,7 @@
system-qemu-image/shared-store
system-qemu-image/shared-store-script
- system-disk-image
+ system-disk-image-in-vm
system-docker-image
virtual-machine
@@ -269,95 +269,6 @@ substitutable."
(eq? (service-kind service) guix-service-type))
(operating-system-services os)))))
-(define* (iso9660-image #:key
- (name "iso9660-image")
- file-system-label
- file-system-uuid
- (system (%current-system))
- (target (%current-target-system))
- (qemu qemu-minimal)
- os
- bootcfg-drv
- bootloader
- (register-closures? (has-guix-service-type? os))
- (inputs '())
- (grub-mkrescue-environment '())
- (substitutable? #t))
- "Return a bootable, stand-alone iso9660 image.
-
-INPUTS is a list of inputs (as for packages)."
- (define schema
- (and register-closures?
- (local-file (search-path %load-path
- "guix/store/schema.sql"))))
-
- (expression->derivation-in-linux-vm
- name
- (with-extensions gcrypt-sqlite3&co
- (with-imported-modules `(,@(source-module-closure '((gnu build vm)
- (guix store database)
- (guix build utils))
- #:select? not-config?)
- ((guix config) => ,(make-config.scm)))
- #~(begin
- (use-modules (gnu build vm)
- (guix store database)
- (guix build utils))
-
- (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")
-
- (let ((inputs
- '#$(append (list parted e2fsprogs dosfstools xorriso)
- (map canonical-package
- (list sed grep coreutils findutils gawk))))
-
-
- (graphs '#$(match inputs
- (((names . _) ...)
- names)))
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs)))
-
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (make-iso9660-image #$xorriso
- '#$grub-mkrescue-environment
- #$(bootloader-package bootloader)
- #$bootcfg-drv
- #$os
- "/xchg/guixsd.iso"
- #:register-closures? #$register-closures?
- #:closures graphs
- #:volume-id #$file-system-label
- #:volume-uuid #$(and=> file-system-uuid
- uuid-bytevector))))))
- #:system system
- #:target target
-
- ;; Keep a local file system for /tmp so that we can populate it directly as
- ;; root and have files owned by root. See <https://bugs.gnu.org/31752>.
- #:file-systems (remove (lambda (file-system)
- (string=? (file-system-mount-point file-system)
- "/tmp"))
- %linux-vm-file-systems)
-
- #:make-disk-image? #f
- #:single-file-output? #t
- #:references-graphs inputs
- #:substitutable? substitutable?
-
- ;; Xorriso seems to be quite memory-hungry, so increase the VM's RAM size.
- #:memory-size 512))
-
(define* (qemu-image #:key
(name "qemu-image")
(system (%current-system))
@@ -624,62 +535,13 @@ system."
;;; VM and disk images.
;;;
-(define* (operating-system-uuid os #:optional (type 'dce))
- "Compute UUID object with a deterministic \"UUID\" for OS, of the given
-TYPE (one of 'iso9660 or 'dce). Return a UUID object."
- ;; Note: For this to be deterministic, we must not hash things that contains
- ;; (directly or indirectly) procedures, for example. That rules out
- ;; anything that contains gexps, thunk or delayed record fields, etc.
-
- (define service-name
- (compose service-type-name service-kind))
-
- (define (file-system-digest fs)
- ;; Return a hashable digest that does not contain 'dependencies' since
- ;; this field can contain procedures.
- (let ((device (file-system-device fs)))
- (list (file-system-mount-point fs)
- (file-system-type fs)
- (file-system-device->string device)
- (file-system-options fs))))
-
- (if (eq? type 'iso9660)
- (let ((pad (compose (cut string-pad <> 2 #\0)
- number->string))
- (h (hash (map service-name (operating-system-services os))
- 3600)))
- (bytevector->uuid
- (string->iso9660-uuid
- (string-append "1970-01-01-"
- (pad (hash (operating-system-host-name os) 24)) "-"
- (pad (quotient h 60)) "-"
- (pad (modulo h 60)) "-"
- (pad (hash (map file-system-digest
- (operating-system-file-systems os))
- 100))))
- 'iso9660))
- (bytevector->uuid
- (uint-list->bytevector
- (list (hash (map file-system-digest
- (operating-system-file-systems os))
- (- (expt 2 32) 1))
- (hash (operating-system-host-name os)
- (- (expt 2 32) 1))
- (hash (map service-name (operating-system-services os))
- (- (expt 2 32) 1))
- (hash (map file-system-digest (operating-system-file-systems os))
- (- (expt 2 32) 1)))
- (endianness little)
- 4)
- type)))
-
-(define* (system-disk-image os
- #:key
- (name "disk-image")
- (file-system-type "ext4")
- (disk-image-size (* 900 (expt 2 20)))
- (volatile? #t)
- (substitutable? #t))
+(define* (system-disk-image-in-vm os
+ #:key
+ (name "disk-image")
+ (file-system-type "ext4")
+ (disk-image-size (* 900 (expt 2 20)))
+ (volatile? #t)
+ (substitutable? #t))
"Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
system described by OS. Said image can be copied on a USB stick as is. When
VOLATILE? is true, the root file system is made volatile; this is useful
@@ -687,25 +549,14 @@ to USB sticks meant to be read-only.
SUBSTITUTABLE? determines whether the returned derivation should be marked as
substitutable."
- (define normalize-label
- ;; ISO labels are all-caps (case-insensitive), but since
- ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
- (if (string=? "iso9660" file-system-type)
- string-upcase
- identity))
-
(define root-label
- ;; Volume name of the root file system.
- (normalize-label "Guix_image"))
+ "Guix_image")
(define (root-uuid os)
;; UUID of the root file system, computed in a deterministic fashion.
;; This is what we use to locate the root file system so it has to be
;; different from the user's own file system UUIDs.
- (operating-system-uuid os
- (if (string=? file-system-type "iso9660")
- 'iso9660
- 'dce)))
+ (operating-system-uuid os 'dce))
(define file-systems-to-keep
(remove (lambda (fs)
@@ -722,11 +573,7 @@ substitutable."
#:volatile-root? volatile?
rest)))
- (bootloader (if (string=? "iso9660" file-system-type)
- (bootloader-configuration
- (inherit (operating-system-bootloader os))
- (bootloader grub-mkrescue-bootloader))
- (operating-system-bootloader os)))
+ (bootloader (operating-system-bootloader os))
;; Force our own root file system. (We need a "/" file system
;; to call 'root-uuid'.)
@@ -744,33 +591,20 @@ substitutable."
(type file-system-type))
file-systems-to-keep))))
(bootcfg (operating-system-bootcfg os)))
- (if (string=? "iso9660" file-system-type)
- (iso9660-image #:name name
- #:file-system-label root-label
- #:file-system-uuid uuid
- #:os os
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg))
- #:grub-mkrescue-environment
- '(("MKRESCUE_SED_MODE" . "mbr_hfs"))
- #:substitutable? substitutable?)
- (qemu-image #:name name
- #:os os
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:disk-image-size disk-image-size
- #:disk-image-format "raw"
- #:file-system-type file-system-type
- #:file-system-label root-label
- #:file-system-uuid uuid
- #:copy-inputs? #t
- #:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg))
- #:substitutable? substitutable?))))
+ (qemu-image #:name name
+ #:os os
+ #:bootcfg-drv bootcfg
+ #:bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os))
+ #:disk-image-size disk-image-size
+ #:disk-image-format "raw"
+ #:file-system-type file-system-type
+ #:file-system-label root-label
+ #:file-system-uuid uuid
+ #:copy-inputs? #t
+ #:inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg))
+ #:substitutable? substitutable?)))
(define* (system-qemu-image os
#:key