diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/file-systems.scm | 130 | ||||
| -rw-r--r-- | gnu/build/marionette.scm | 7 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 53 |
3 files changed, 45 insertions, 145 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..6da4fa654e 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,18 +372,39 @@ 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 |