aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/examples/bare-bones.tmpl4
-rw-r--r--gnu/system/file-systems.scm26
-rw-r--r--gnu/system/install.scm17
-rw-r--r--gnu/system/mapped-devices.scm7
-rw-r--r--gnu/system/pam.scm47
-rw-r--r--gnu/system/uuid.scm283
-rw-r--r--gnu/system/vm.scm79
7 files changed, 422 insertions, 41 deletions
diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl
index 459d241885..7e0c8fbee0 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -3,7 +3,7 @@
(use-modules (gnu))
(use-service-modules networking ssh)
-(use-package-modules admin)
+(use-package-modules screen ssh)
(operating-system
(host-name "komputilo")
@@ -40,7 +40,7 @@
%base-user-accounts))
;; Globally-installed packages.
- (packages (cons tcpdump %base-packages))
+ (packages (cons* screen openssh %base-packages))
;; Add services to the baseline: a DHCP client and
;; an SSH server.
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index bbac23fbdf..52f16676f5 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,9 +20,9 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (guix records)
- #:use-module ((gnu build file-systems)
- #:select (string->uuid uuid->string))
- #:re-export (string->uuid
+ #:use-module (gnu system uuid)
+ #:re-export (uuid ;backward compatibility
+ string->uuid
uuid->string)
#:export (<file-system>
file-system
@@ -44,7 +44,6 @@
file-system->spec
spec->file-system
specification->file-system-mapping
- uuid
%fuse-control-file-system
%binary-format-file-system
@@ -157,7 +156,10 @@ store--e.g., if FS is the root file system."
initrd code."
(match fs
(($ <file-system> device title mount-point type flags options _ _ check?)
- (list device title mount-point type flags options check?))))
+ (list (if (uuid? device)
+ (uuid-bytevector device)
+ device)
+ title mount-point type flags options check?))))
(define (spec->file-system sexp)
"Deserialize SEXP, a list, to the corresponding <file-system> object."
@@ -186,20 +188,6 @@ TARGET in the other system."
(target spec)
(writable? writable?)))))
-(define-syntax uuid
- (lambda (s)
- "Return the bytevector corresponding to the given UUID representation."
- (syntax-case s ()
- ((_ str)
- (string? (syntax->datum #'str))
- ;; A literal string: do the conversion at expansion time.
- (let ((bv (string->uuid (syntax->datum #'str))))
- (unless bv
- (syntax-violation 'uuid "invalid UUID" s))
- (datum->syntax #'str bv)))
- ((_ str)
- #'(string->uuid str)))))
-
;;;
;;; Common file systems.
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 7f6ffe9582..eb362f91a8 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -31,6 +31,7 @@
#:use-module (gnu packages bash)
#:use-module (gnu packages bootloaders)
#:use-module (gnu packages linux)
+ #:use-module (gnu packages ssh)
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages package-management)
#:use-module (gnu packages disk)
@@ -214,6 +215,9 @@ You have been warned. Thanks for being so brave.
(auto-login "root")
(login-pause? #t))))
+ (define bare-bones-os
+ (load "examples/bare-bones.tmpl"))
+
(list (mingetty-service (mingetty-configuration
(tty "tty1")
(auto-login "root")))
@@ -283,7 +287,11 @@ You have been warned. Thanks for being so brave.
;; connections to this system to work.
(service special-files-service-type
`(("/bin/sh" ,(file-append (canonical-package bash)
- "/bin/sh")))))))
+ "/bin/sh"))))
+
+ ;; Keep a reference to BARE-BONES-OS to make sure it can be
+ ;; installed without downloading/building anything.
+ (service gc-root-service-type (list bare-bones-os)))))
(define %issue
;; Greeting.
@@ -337,9 +345,9 @@ Use Alt-F2 for documentation.
(issue %issue)
(services %installation-services)
- ;; We don't need setuid programs so pass the empty list so we don't pull
- ;; additional programs here.
- (setuid-programs '())
+ ;; We don't need setuid programs, except for 'passwd', which can be handy
+ ;; if one is to allow remote SSH login to the machine being installed.
+ (setuid-programs (list (file-append shadow "/bin/passwd")))
(pam-services
;; Explicitly allow for empty passwords.
@@ -352,6 +360,7 @@ Use Alt-F2 for documentation.
mdadm
dosfstools ;mkfs.fat, for the UEFI boot partition
btrfs-progs
+ openssh ;we already have sshd, having ssh/scp can help
wireless-tools iw wpa-supplicant-minimal iproute
;; XXX: We used to have GNU fdisk here, but as of version
;; 2.0.0a, that pulls Guile 1.8, which takes unreasonable
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 18b9f5b4b6..17cf6b7163 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Mark H Weaver <mhw@netris.org>
;;;
@@ -24,6 +24,7 @@
#:use-module (guix modules)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
+ #:use-module (gnu system uuid)
#:autoload (gnu packages cryptsetup) (cryptsetup-static)
#:autoload (gnu packages linux) (mdadm-static)
#:use-module (srfi srfi-1)
@@ -99,7 +100,9 @@
'cryptsetup'."
(with-imported-modules (source-module-closure
'((gnu build file-systems)))
- #~(let ((source #$source))
+ #~(let ((source #$(if (uuid? source)
+ (uuid-bytevector source)
+ source)))
;; XXX: 'use-modules' should be at the top level.
(use-modules (rnrs bytevectors) ;bytevector?
((gnu build file-systems)
diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm
index eedf933946..13f76a50ed 100644
--- a/gnu/system/pam.scm
+++ b/gnu/system/pam.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -50,6 +50,9 @@
unix-pam-service
base-pam-services
+ session-environment-service
+ session-environment-service-type
+
pam-root-service-type
pam-root-service))
@@ -278,6 +281,48 @@ authenticate to run COMMAND."
;;;
+;;; System-wide environment variables.
+;;;
+
+(define (environment-variables->environment-file vars)
+ "Return a file for pam_env(8) that contains environment variables VARS."
+ (apply mixed-text-file "environment"
+ (append-map (match-lambda
+ ((key . value)
+ (list key "=" value "\n")))
+ vars)))
+
+(define session-environment-service-type
+ (service-type
+ (name 'session-environment)
+ (extensions
+ (list (service-extension
+ etc-service-type
+ (lambda (vars)
+ (list `("environment"
+ ,(environment-variables->environment-file vars)))))))
+ (compose concatenate)
+ (extend append)
+ (description
+ "Populate @file{/etc/environment}, which is honored by @code{pam_env},
+with the specified environment variables. The value of this service is a list
+of name/value pairs for environments variables, such as:
+
+@example
+'((\"TZ\" . \"Canada/Pacific\"))
+@end example\n")))
+
+(define (session-environment-service vars)
+ "Return a service that builds the @file{/etc/environment}, which can be read
+by PAM-aware applications to set environment variables for sessions.
+
+VARS should be an association list in which both the keys and the values are
+strings or string-valued gexps."
+ (service session-environment-service-type vars))
+
+
+
+;;;
;;; PAM root service.
;;;
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
new file mode 100644
index 0000000000..6470abb8cc
--- /dev/null
+++ b/gnu/system/uuid.scm
@@ -0,0 +1,283 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
+;;;
+;;; 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 uuid)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 format)
+ #:export (uuid
+ uuid?
+ uuid-type
+ uuid-bytevector
+
+ bytevector->uuid
+
+ uuid->string
+ dce-uuid->string
+ string->uuid
+ string->dce-uuid
+ string->iso9660-uuid
+ string->ext2-uuid
+ string->ext3-uuid
+ string->ext4-uuid
+ string->btrfs-uuid
+ string->fat32-uuid
+ iso9660-uuid->string
+
+ ;; XXX: For lack of a better place.
+ sub-bytevector
+ latin1->string))
+
+
+;;;
+;;; Tools that lack a better place.
+;;;
+
+(define (sub-bytevector bv start size)
+ "Return a copy of the SIZE bytes of BV starting from offset START."
+ (let ((result (make-bytevector size)))
+ (bytevector-copy! bv start result 0 size)
+ result))
+
+(define (latin1->string bv terminator)
+ "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate
+that takes a number and returns #t when a termination character is found."
+ (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
+ (if (null? bytes)
+ #f
+ (list->string (map integer->char bytes)))))
+
+
+;;;
+;;; DCE UUIDs.
+;;;
+
+(define-syntax %network-byte-order
+ (identifier-syntax (endianness big)))
+
+(define (dce-uuid->string uuid)
+ "Convert UUID, a 16-byte bytevector, to its string representation, something
+like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
+ ;; See <https://tools.ietf.org/html/rfc4122>.
+ (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
+ (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
+ (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
+ (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
+ (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
+ (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
+ time-low time-mid time-hi clock-seq node)))
+
+(define %uuid-rx
+ ;; The regexp of a UUID.
+ (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
+
+(define (string->dce-uuid str)
+ "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
+return its contents as a 16-byte bytevector. Return #f if STR is not a valid
+UUID representation."
+ (and=> (regexp-exec %uuid-rx str)
+ (lambda (match)
+ (letrec-syntax ((hex->number
+ (syntax-rules ()
+ ((_ index)
+ (string->number (match:substring match index)
+ 16))))
+ (put!
+ (syntax-rules ()
+ ((_ bv index (number len) rest ...)
+ (begin
+ (bytevector-uint-set! bv index number
+ (endianness big) len)
+ (put! bv (+ index len) rest ...)))
+ ((_ bv index)
+ bv))))
+ (let ((time-low (hex->number 1))
+ (time-mid (hex->number 2))
+ (time-hi (hex->number 3))
+ (clock-seq (hex->number 4))
+ (node (hex->number 5))
+ (uuid (make-bytevector 16)))
+ (put! uuid 0
+ (time-low 4) (time-mid 2) (time-hi 2)
+ (clock-seq 2) (node 6)))))))
+
+
+;;;
+;;; ISO-9660.
+;;;
+
+;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
+
+(define %iso9660-uuid-rx
+ ;; Y m d H M S ss
+ (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$"))
+(define (string->iso9660-uuid str)
+ "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid).
+Return its contents as a 16-byte bytevector. Return #f if STR is not a valid
+ISO9660 UUID representation."
+ (and=> (regexp-exec %iso9660-uuid-rx str)
+ (lambda (match)
+ (letrec-syntax ((match-numerals
+ (syntax-rules ()
+ ((_ index (name rest ...) body)
+ (let ((name (match:substring match index)))
+ (match-numerals (+ 1 index) (rest ...) body)))
+ ((_ index () body)
+ body))))
+ (match-numerals 1 (year month day hour minute second hundredths)
+ (string->utf8 (string-append year month day
+ hour minute second hundredths)))))))
+(define (iso9660-uuid->string uuid)
+ "Given an UUID bytevector, return its timestamp string."
+ (define (digits->string bytes)
+ (latin1->string bytes (lambda (c) #f)))
+ (let* ((year (sub-bytevector uuid 0 4))
+ (month (sub-bytevector uuid 4 2))
+ (day (sub-bytevector uuid 6 2))
+ (hour (sub-bytevector uuid 8 2))
+ (minute (sub-bytevector uuid 10 2))
+ (second (sub-bytevector uuid 12 2))
+ (hundredths (sub-bytevector uuid 14 2))
+ (parts (list year month day hour minute second hundredths)))
+ (string-append (string-join (map digits->string parts) "-"))))
+
+
+;;;
+;;; FAT32.
+;;;
+
+(define-syntax %fat32-endianness
+ ;; Endianness of FAT file systems.
+ (identifier-syntax (endianness little)))
+
+(define (fat32-uuid->string uuid)
+ "Convert fat32 UUID, a 4-byte bytevector, to its string representation."
+ (let ((high (bytevector-uint-ref uuid 0 %fat32-endianness 2))
+ (low (bytevector-uint-ref uuid 2 %fat32-endianness 2)))
+ (format #f "~:@(~x-~x~)" low high)))
+
+(define %fat32-uuid-rx
+ (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
+
+(define (string->fat32-uuid str)
+ "Parse STR, which is in FAT32 format, and return a bytevector or #f."
+ (match (regexp-exec %fat32-uuid-rx str)
+ (#f
+ #f)
+ (rx-match
+ (uint-list->bytevector (list (string->number
+ (match:substring rx-match 2) 16)
+ (string->number
+ (match:substring rx-match 1) 16))
+ %fat32-endianness
+ 2))))
+
+
+;;;
+;;; Generic interface.
+;;;
+
+(define string->ext2-uuid string->dce-uuid)
+(define string->ext3-uuid string->dce-uuid)
+(define string->ext4-uuid string->dce-uuid)
+(define string->btrfs-uuid string->dce-uuid)
+
+(define-syntax vhashq
+ (syntax-rules (=>)
+ ((_)
+ vlist-null)
+ ((_ (key others ... => value) rest ...)
+ (vhash-consq key value
+ (vhashq (others ... => value) rest ...)))
+ ((_ (=> value) rest ...)
+ (vhashq rest ...))))
+
+(define %uuid-parsers
+ (vhashq
+ ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
+ ('fat32 'fat => string->fat32-uuid)
+ ('iso9660 => string->iso9660-uuid)))
+
+(define %uuid-printers
+ (vhashq
+ ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string)
+ ('iso9660 => iso9660-uuid->string)
+ ('fat32 'fat => fat32-uuid->string)))
+
+(define* (string->uuid str #:optional (type 'dce))
+ "Parse STR as a UUID of the given TYPE. On success, return the
+corresponding bytevector; otherwise return #f."
+ (match (vhash-assq type %uuid-parsers)
+ (#f #f)
+ ((_ . (? procedure? parse)) (parse str))))
+
+;; High-level UUID representation that carries its type with it.
+;;
+;; This is necessary to serialize bytevectors with the right printer in some
+;; circumstances. For instance, GRUB "search --fs-uuid" command compares the
+;; string representation of UUIDs, not the raw bytes; thus, when emitting a
+;; GRUB 'search' command, we need to procedure the right string representation
+;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>).
+(define-record-type <uuid>
+ (make-uuid type bv)
+ uuid?
+ (type uuid-type) ;'dce | 'iso9660 | ...
+ (bv uuid-bytevector))
+
+(define* (bytevector->uuid bv #:optional (type 'dce))
+ "Return a UUID object make of BV and TYPE."
+ (make-uuid type bv))
+
+(define-syntax uuid
+ (lambda (s)
+ "Return the UUID object corresponding to the given UUID representation."
+ (syntax-case s (quote)
+ ((_ str (quote type))
+ (and (string? (syntax->datum #'str))
+ (identifier? #'type))
+ ;; A literal string: do the conversion at expansion time.
+ (let ((bv (string->uuid (syntax->datum #'str)
+ (syntax->datum #'type))))
+ (unless bv
+ (syntax-violation 'uuid "invalid UUID" s))
+ #`(make-uuid 'type #,(datum->syntax s bv))))
+ ((_ str)
+ (string? (syntax->datum #'str))
+ #'(uuid str 'dce))
+ ((_ str)
+ #'(make-uuid 'dce (string->uuid str 'dce)))
+ ((_ str type)
+ #'(make-uuid type (string->uuid str type))))))
+
+(define uuid->string
+ ;; Convert the given bytevector or UUID object, to the corresponding UUID
+ ;; string representation.
+ (match-lambda*
+ (((? bytevector? bv))
+ (uuid->string bv 'dce))
+ (((? bytevector? bv) type)
+ (match (vhash-assq type %uuid-printers)
+ (#f #f)
+ ((_ . (? procedure? unparse)) (unparse bv))))
+ (((? uuid? uuid))
+ (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 4494af0031..78143e4f7a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -57,9 +57,11 @@
#:use-module (gnu system file-systems)
#:use-module (gnu system)
#:use-module (gnu services)
+ #:use-module (gnu system uuid)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:export (expression->derivation-in-linux-vm
@@ -192,6 +194,7 @@ made available under the /xchg CIFS share."
os-drv
bootcfg-drv
bootloader
+ register-closures?
(inputs '()))
"Return a bootable, stand-alone iso9660 image.
@@ -207,8 +210,13 @@ INPUTS is a list of inputs (as for packages)."
(let ((inputs
'#$(append (list qemu parted e2fsprogs dosfstools xorriso)
(map canonical-package
- (list sed grep coreutils findutils gawk))))
+ (list sed grep coreutils findutils gawk))
+ (if register-closures? (list guix) '())))
+
+ (graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs.
(to-register
@@ -222,8 +230,11 @@ INPUTS is a list of inputs (as for packages)."
#$bootcfg-drv
#$os-drv
"/xchg/guixsd.iso"
+ #:register-closures? #$register-closures?
+ #:closures graphs
#:volume-id #$file-system-label
- #:volume-uuid #$file-system-uuid)
+ #:volume-uuid #$(and=> file-system-uuid
+ uuid-bytevector))
(reboot))))
#:system system
#:make-disk-image? #f
@@ -238,6 +249,7 @@ INPUTS is a list of inputs (as for packages)."
(disk-image-format "qcow2")
(file-system-type "ext4")
file-system-label
+ file-system-uuid
os-drv
bootcfg-drv
bootloader
@@ -247,7 +259,10 @@ INPUTS is a list of inputs (as for packages)."
"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
-partition. The returned image is a full disk image that runs OS-DERIVATION,
+partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
+partition (a UUID object).
+
+The returned image is a full disk image that runs OS-DERIVATION,
with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
file (GRUB-CONFIGURATION must be the name of a file in the VM.)
@@ -297,6 +312,8 @@ the image."
(partitions (list (partition
(size root-size)
(label #$file-system-label)
+ (uuid #$(and=> file-system-uuid
+ uuid-bytevector))
(file-system #$file-system-type)
(flags '(boot))
(initializer initialize))
@@ -334,6 +351,35 @@ the image."
;;; 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."
+ (if (eq? type 'iso9660)
+ (let ((pad (compose (cut string-pad <> 2 #\0)
+ number->string))
+ (h (hash (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 (operating-system-file-systems os) 100))))
+ 'iso9660))
+ (bytevector->uuid
+ (uint-list->bytevector
+ (list (hash file-system-type
+ (expt 2 32))
+ (hash (operating-system-host-name os)
+ (expt 2 32))
+ (hash (operating-system-services os)
+ (expt 2 32))
+ (hash (operating-system-file-systems os)
+ (expt 2 32)))
+ (endianness little)
+ 4)
+ type)))
+
(define* (system-disk-image os
#:key
(name "disk-image")
@@ -350,12 +396,20 @@ to USB sticks meant to be read-only."
(if (string=? "iso9660" file-system-type)
string-upcase
identity))
+
(define root-label
- ;; Volume name of the root file system. Since we don't know which device
- ;; will hold it, we use the volume name to find it (using the UUID would
- ;; be even better, but somewhat less convenient.)
+ ;; Volume name of the root file system.
(normalize-label "GuixSD_image"))
+ (define root-uuid
+ ;; 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)))
+
(define file-systems-to-keep
(remove (lambda (fs)
(string=? (file-system-mount-point fs) "/"))
@@ -379,8 +433,8 @@ to USB sticks meant to be read-only."
;; Force our own root file system.
(file-systems (cons (file-system
(mount-point "/")
- (device root-label)
- (title 'label)
+ (device root-uuid)
+ (title 'uuid)
(type file-system-type))
file-systems-to-keep)))))
@@ -389,8 +443,9 @@ to USB sticks meant to be read-only."
(if (string=? "iso9660" file-system-type)
(iso9660-image #:name name
#:file-system-label root-label
- #:file-system-uuid #f
+ #:file-system-uuid root-uuid
#:os-drv os-drv
+ #:register-closures? #t
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
@@ -403,11 +458,9 @@ to USB sticks meant to be read-only."
(operating-system-bootloader os))
#:disk-image-size disk-image-size
#:disk-image-format "raw"
- #:file-system-type (if (string=? "iso9660"
- file-system-type)
- "ext4"
- file-system-type)
+ #:file-system-type file-system-type
#:file-system-label root-label
+ #:file-system-uuid root-uuid
#:copy-inputs? #t
#:register-closures? #t
#:inputs `(("system" ,os-drv)