summaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/file-systems.scm130
-rw-r--r--gnu/build/marionette.scm7
-rw-r--r--gnu/build/vm.scm66
3 files changed, 45 insertions, 158 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 203fbdfffb..32885f1d2e 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -19,6 +19,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build file-systems)
+ #:use-module (gnu system uuid)
#:use-module (guix build utils)
#:use-module (guix build bournish)
#:use-module (guix build syscalls)
@@ -26,8 +27,6 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
- #:use-module (ice-9 format)
- #:use-module (ice-9 regex)
#:use-module (system foreign)
#:autoload (system repl repl) (start-repl)
#:use-module (srfi srfi-1)
@@ -41,15 +40,6 @@
find-partition-by-luks-uuid
canonicalize-device-spec
- uuid->string
- string->uuid
- string->iso9660-uuid
- string->ext2-uuid
- string->ext3-uuid
- string->ext4-uuid
- string->btrfs-uuid
- iso9660-uuid->string
-
bind-mount
mount-flags->bit-mask
@@ -95,20 +85,6 @@ takes a bytevector and returns #t when it's a valid superblock."
(and (magic? block)
block)))))))))
-(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)))))
-
(define null-terminated-latin1->string
(cut latin1->string <> zero?))
@@ -196,10 +172,6 @@ if DEVICE does not contain a btrfs file system."
;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
-(define-syntax %fat32-endianness
- ;; Endianness of fat file systems.
- (identifier-syntax (endianness little)))
-
(define (fat32-superblock? sblock)
"Return #t when SBLOCK is a fat32 superblock."
(bytevector=? (sub-bytevector sblock 82 8)
@@ -214,12 +186,6 @@ if DEVICE does not contain a btrfs file system."
"Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
(sub-bytevector sblock 67 4))
-(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-superblock-volume-name sblock)
"Return the volume name of SBLOCK as a string of at most 11 characters, or
#f if SBLOCK has no volume name. The volume name is a latin1 string.
@@ -241,27 +207,6 @@ Trailing spaces are trimmed."
;; <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-superblock? sblock)
"Return #t when SBLOCK is an iso9660 volume descriptor."
(bytevector=? (sub-bytevector sblock 1 6)
@@ -308,20 +253,6 @@ SBLOCK as a bytevector. If that's not set, returns the creation time."
modification-time)))
(sub-bytevector time 0 16))) ; strips GMT offset.
-(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) "-"))))
-
(define (iso9660-superblock-volume-name sblock)
"Return the volume name of SBLOCK as a string. The volume name is an ASCII
string. Trailing spaces are trimmed."
@@ -509,65 +440,6 @@ were found."
(find-partition luks-partition-uuid-predicate))
-;;;
-;;; UUIDs.
-;;;
-
-(define-syntax %network-byte-order
- (identifier-syntax (endianness big)))
-
-(define (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->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)))))))
-
-(define string->ext2-uuid string->uuid)
-(define string->ext3-uuid string->uuid)
-(define string->ext4-uuid string->uuid)
-(define string->btrfs-uuid string->uuid)
-
-
(define* (canonicalize-device-spec spec #:optional (title 'any))
"Return the device name corresponding to SPEC. TITLE is a symbol, one of
the following:
diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index f35f0fbca1..7554a710a0 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -165,13 +165,14 @@ QEMU monitor and to the guest's backdoor REPL."
(newline repl)
(read repl))))
-(define* (wait-for-file file marionette #:key (timeout 10))
- "Wait until FILE exists in MARIONETTE; 'read' its content and return it. If
+(define* (wait-for-file file marionette
+ #:key (timeout 10) (read 'read))
+ "Wait until FILE exists in MARIONETTE; READ its content and return it. If
FILE has not shown up after TIMEOUT seconds, raise an error."
(match (marionette-eval
`(let loop ((i ,timeout))
(cond ((file-exists? ,file)
- (cons 'success (call-with-input-file ,file read)))
+ (cons 'success (call-with-input-file ,file ,read)))
((> i 0)
(sleep 1)
(loop (- i 1)))
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 727494ad93..7537f81509 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -26,7 +26,7 @@
#:use-module (guix build syscalls)
#:use-module (gnu build linux-boot)
#:use-module (gnu build install)
- #:use-module (gnu build file-systems)
+ #:use-module (gnu system uuid)
#:use-module (guix records)
#:use-module ((guix combinators) #:select (fold2))
#:use-module (ice-9 format)
@@ -163,6 +163,7 @@ the #:references-graphs parameter of 'derivation'."
(size partition-size)
(file-system partition-file-system (default "ext4"))
(label partition-label (default #f))
+ (uuid partition-uuid (default #f))
(flags partition-flags (default '()))
(initializer partition-initializer (default (const #t))))
@@ -236,22 +237,26 @@ actual /dev name based on DEVICE."
(define MS_BIND 4096) ; <sys/mounts.h> again!
(define* (create-ext-file-system partition type
- #:key label)
+ #:key label uuid)
"Create an ext-family filesystem of TYPE on PARTITION. If LABEL is true,
-use that as the volume name."
+use that as the volume name. If UUID is true, use it as the partition UUID."
(format #t "creating ~a partition...\n" type)
(unless (zero? (apply system* (string-append "mkfs." type)
"-F" partition
- (if label
- `("-L" ,label)
- '())))
+ `(,@(if label
+ `("-L" ,label)
+ '())
+ ,@(if uuid
+ `("-U" ,(uuid->string uuid))
+ '()))))
(error "failed to create partition")))
(define* (create-fat-file-system partition
- #:key label)
+ #:key label uuid)
"Create a FAT filesystem on PARTITION. The number of File Allocation Tables
will be determined based on filesystem size. If LABEL is true, use that as the
volume name."
+ ;; FIXME: UUID is ignored!
(format #t "creating FAT partition...\n")
(unless (zero? (apply system* "mkfs.fat" partition
(if label
@@ -260,13 +265,13 @@ volume name."
(error "failed to create FAT partition")))
(define* (format-partition partition type
- #:key label)
+ #:key label uuid)
"Create a file system TYPE on PARTITION. If LABEL is true, use that as the
volume name."
(cond ((string-prefix? "ext" type)
- (create-ext-file-system partition type #:label label))
+ (create-ext-file-system partition type #:label label #:uuid uuid))
((or (string-prefix? "fat" type) (string= "vfat" type))
- (create-fat-file-system partition #:label label))
+ (create-fat-file-system partition #:label label #:uuid uuid))
(else (error "Unsupported file system."))))
(define (initialize-partition partition)
@@ -275,7 +280,8 @@ it, run its initializer, and unmount it."
(let ((target "/fs"))
(format-partition (partition-device partition)
(partition-file-system partition)
- #:label (partition-label partition))
+ #:label (partition-label partition)
+ #:uuid (partition-uuid partition))
(mkdir-p target)
(mount (partition-device partition) target
(partition-file-system partition))
@@ -366,32 +372,40 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(error "failed to create GRUB EFI image"))))
(define* (make-iso9660-image grub config-file os-drv target
- #:key (volume-id "GuixSD_image") (volume-uuid #f))
+ #:key (volume-id "GuixSD_image") (volume-uuid #f)
+ register-closures? (closures '()))
"Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
GRUB configuration and OS-DRV as the stuff in it."
- (let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue")))
+ (let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue"))
+ (target-store (string-append "/tmp/root" (%store-directory))))
(mkdir-p "/tmp/root/var/run")
(mkdir-p "/tmp/root/run")
+ (mkdir-p "/tmp/root/mnt")
+
+ (mkdir-p target-store)
+ (mount (%store-directory) target-store "" MS_BIND)
+
+ (when register-closures?
+ (display "registering closures...\n")
+ (for-each (lambda (closure)
+ (register-closure
+ "/tmp/root"
+ (string-append "/xchg/" closure)
+ ;; XXX: Using deduplication causes cross device link errors.
+ #:deduplicate? #f))
+ closures))
+
(unless (zero? (apply system*
`(,grub-mkrescue "-o" ,target
,(string-append "boot/grub/grub.cfg=" config-file)
,(string-append "gnu/store=" os-drv "/..")
"var=/tmp/root/var"
"run=/tmp/root/run"
+ ;; /mnt is used as part of the installation
+ ;; process, as the mount point for the target
+ ;; filesystem, so create it.
+ "mnt=/tmp/root/mnt"
"--"
- ;; Store two copies of the headers.
- ;; The resulting ISO-9660 image has a DOS MBR and
- ;; one protective partition (with type 0xCD).
- ;; Because GuixSD only uses actual partitions
- ;; rather than what /proc/partitions returns, work
- ;; around it by storing the primary volume
- ;; descriptor twice, once where it should be and
- ;; once in the partition.
- ;; Allegedly, otherwise, many other GNU tools
- ;; (automounters etc) would also be confused by
- ;; the extra partition so it makes sense to
- ;; store two copies in any case.
- "-boot_image" "any" "partition_offset=16"
"-volid" ,(string-upcase volume-id)
,@(if volume-uuid
`("-volume_date" "uuid"
generated by cgit v1.2.3 (git 2.25.4) at 2024-07-11 13:22:23 +0000