From ef9fc40dda0f14366d0612bcb940f4fe7285e786 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 29 May 2014 23:07:43 +0200 Subject: vm: Allow a volume name to be specified for the root partition. * guix/build/vm.scm (format-partition): Add #:label parameter, and honor it. (initialize-hard-disk): Add #:file-system-label parameter, and pass it to 'format-partition'. * gnu/system/vm.scm (qemu-image): Add #:file-system-label parameter and pass it to 'initialize-hard-disk'. --- guix/build/vm.scm | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) (limited to 'guix/build') diff --git a/guix/build/vm.scm b/guix/build/vm.scm index e559542f0a..c1deb35664 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -158,10 +158,16 @@ (define (graph-from-file file) (define MS_BIND 4096) ; again! -(define (format-partition partition type) - "Create a file system TYPE on PARTITION." +(define* (format-partition partition type + #:key label) + "Create a file system TYPE on PARTITION. If LABEL is true, use that as the +volume name." (format #t "creating ~a partition...\n" type) - (unless (zero? (system* (string-append "mkfs." type) "-F" partition)) + (unless (zero? (apply system* (string-append "mkfs." type) + "-F" partition + (if label + `("-L" ,label) + '()))) (error "failed to create partition"))) (define* (initialize-root-partition target-directory @@ -204,13 +210,15 @@ (define* (initialize-hard-disk device grub.cfg disk-image-size (file-system-type "ext4") + file-system-label (closures '()) copy-closures? (register-closures? #t)) - "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a -FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is -true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is -true, copy all of CLOSURES to the partition." + "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE +partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with +GRUB installed. If REGISTER-CLOSURES? is true, register all of CLOSURES is +the partition's store. If COPY-CLOSURES? is true, copy all of CLOSURES to the +partition." (define target-directory "/fs") @@ -220,7 +228,8 @@ (define partition (initialize-partition-table device (- disk-image-size (* 5 (expt 2 20)))) - (format-partition partition file-system-type) + (format-partition partition file-system-type + #:label file-system-label) (display "mounting partition...\n") (mkdir target-directory) -- cgit v1.2.3 From 85a83edb369dcebd1019674427dda9e6b3e2ed4b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 30 May 2014 23:44:28 +0200 Subject: linux-initrd: Allow use of volume labels in 'file-system' declarations. * guix/build/linux-initrd.scm (%ext2-endianness, %ext2-sblock-magic, %ext2-sblock-creator-os, %ext2-sblock-uuid, %ext2-sblock-volume-name): New macros. (read-ext2-superblock, ext2-superblock-uuid, ext2-superblock-volume-name, disk-partitions, partition-label-predicate, find-partition-by-label, canonicalize-device-spec): New procedures. (mount-file-system): Use 'canonicalize-device-spec' on SOURCE. (boot-system): Likewise for ROOT. * doc/guix.texi (Using the Configuration System): Adjust 'file-system' declaration accordingly. --- doc/guix.texi | 2 +- guix/build/linux-initrd.scm | 116 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 115 insertions(+), 3 deletions(-) (limited to 'guix/build') diff --git a/doc/guix.texi b/doc/guix.texi index c10479ff12..eeadb04d78 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3130,7 +3130,7 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: (bootloader (grub-configuration (device "/dev/sda"))) (file-systems (list (file-system - (device "/dev/disk/by-label/root") + (device "/dev/sda1") ; or partition label (mount-point "/") (type "ext3")))) (users (list (user-account diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 5be3c1ac2a..3873ade13e 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -18,12 +18,14 @@ (define-module (guix build linux-initrd) #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:autoload (system base compile) (compile-file) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) #:use-module (ice-9 ftw) #:use-module (guix build utils) #:export (mount-essential-file-systems @@ -31,9 +33,15 @@ (define-module (guix build linux-initrd) find-long-option make-essential-device-nodes configure-qemu-networking + + disk-partitions + partition-label-predicate + find-partition-by-label + check-file-system mount-file-system bind-mount + load-linux-module* device-number boot-system)) @@ -88,6 +96,107 @@ (define (find-long-option option arguments) (lambda (arg) (substring arg (+ 1 (string-index arg #\=))))))) +(define-syntax %ext2-endianness + ;; Endianness of ext2 file systems. + (identifier-syntax (endianness little))) + +;; Offset in bytes of interesting parts of an ext2 superblock. See +;; . +;; TODO: Use "packed structs" from Guile-OpenGL or similar. +(define-syntax %ext2-sblock-magic (identifier-syntax 56)) +(define-syntax %ext2-sblock-creator-os (identifier-syntax 72)) +(define-syntax %ext2-sblock-uuid (identifier-syntax 104)) +(define-syntax %ext2-sblock-volume-name (identifier-syntax 120)) + +(define (read-ext2-superblock device) + "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f +if DEVICE does not contain an ext2 file system." + (define %ext2-magic + ;; The magic bytes that identify an ext2 file system. + #xef53) + + (call-with-input-file device + (lambda (port) + (seek port 1024 SEEK_SET) + (let* ((block (get-bytevector-n port 264)) + (magic (bytevector-u16-ref block %ext2-sblock-magic + %ext2-endianness))) + (and (= magic %ext2-magic) + block))))) + +(define (ext2-superblock-uuid sblock) + "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector." + (let ((uuid (make-bytevector 16))) + (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16) + uuid)) + +(define (ext2-superblock-volume-name sblock) + "Return the volume name of SBLOCK as a string of at most 16 characters, or +#f if SBLOCK has no volume name." + (let ((bv (make-bytevector 16))) + (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16) + + ;; This is a Latin-1, nul-terminated string. + (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv)))) + (if (null? bytes) + #f + (list->string (map integer->char bytes)))))) + +(define (disk-partitions) + "Return the list of device names corresponding to valid disk partitions." + (define (partition? major minor) + (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor))) + (catch 'system-error + (lambda () + (not (zero? (call-with-input-file marker read)))) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args)))))) + + (call-with-input-file "/proc/partitions" + (lambda (port) + ;; Skip the two header lines. + (read-line port) + (read-line port) + + ;; Read each subsequent line, and extract the last space-separated + ;; field. + (let loop ((parts '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse parts) + (match (string-tokenize line) + (((= string->number major) (= string->number minor) + blocks name) + (if (partition? major minor) + (loop (cons name parts)) + (loop parts)))))))))) + +(define (partition-label-predicate label) + "Return a procedure that, when applied to a partition name such as \"sda1\", +return #t if that partition's volume name is LABEL." + (lambda (part) + (let* ((device (string-append "/dev/" part)) + (sblock (read-ext2-superblock device))) + (and sblock + (string=? (ext2-superblock-volume-name sblock) + label))))) + +(define (find-partition-by-label label) + "Return the first partition found whose volume name is LABEL, or #f if none +were found." + (and=> (find (partition-label-predicate label) + (disk-partitions)) + (cut string-append "/dev/" <>))) + +(define (canonicalize-device-spec spec) + "Given SPEC, a string such as \"/dev/sda1\" or \"my-root-part\", return the +corresponding device name." + (if (string-prefix? "/" spec) + spec + (or (find-partition-by-label spec) spec))) + (define* (make-essential-device-nodes #:key (root "/")) "Make essential device nodes under ROOT/dev." ;; The hand-made udev! @@ -321,7 +430,8 @@ (define flags->bit-mask (match spec ((source mount-point type (flags ...) options check?) - (let ((mount-point (string-append root "/" mount-point))) + (let ((source (canonicalize-device-spec source)) + (mount-point (string-append root "/" mount-point))) (when check? (check-file-system source type)) (mkdir-p mount-point) @@ -381,6 +491,7 @@ (define (switch-root root) (close-port console)))) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? @@ -451,7 +562,8 @@ (define root-fs-type (unless (file-exists? "/root") (mkdir "/root")) (if root - (mount-root-file-system root root-fs-type + (mount-root-file-system (canonicalize-device-spec root) + root-fs-type #:volatile-root? volatile-root?) (mount "none" "/root" "tmpfs")) -- cgit v1.2.3 From 1bb784ea05b2eeac13f7355ae2f51fbd302a36b7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 31 May 2014 15:55:38 +0200 Subject: linux-initrd: Gracefully deal with partitions with no label. * guix/build/linux-initrd.scm (partition-label-predicate): Check whether 'ext2-superblock-volume-name' returns #f, and return #f if it does. --- guix/build/linux-initrd.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 3873ade13e..1c44c5c5c7 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -180,8 +180,9 @@ (define (partition-label-predicate label) (let* ((device (string-append "/dev/" part)) (sblock (read-ext2-superblock device))) (and sblock - (string=? (ext2-superblock-volume-name sblock) - label))))) + (let ((volume (ext2-superblock-volume-name sblock))) + (and volume + (string=? volume label))))))) (define (find-partition-by-label label) "Return the first partition found whose volume name is LABEL, or #f if none -- cgit v1.2.3 From 009d831167edd37acdfc3f6a5c35618fc82804e4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Jun 2014 21:20:54 +0200 Subject: linux-initrd: Gracefully handle missing /dev nodes. * guix/build/linux-initrd.scm (partition-label-predicate): Catch 'system-error' around 'read-ext2-superblock'; return #f upon ENOENT. --- guix/build/linux-initrd.scm | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 1c44c5c5c7..9a13e7213c 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -178,7 +178,20 @@ (define (partition-label-predicate label) return #t if that partition's volume name is LABEL." (lambda (part) (let* ((device (string-append "/dev/" part)) - (sblock (read-ext2-superblock device))) + (sblock (catch 'system-error + (lambda () + (read-ext2-superblock device)) + (lambda args + ;; When running on the hand-made /dev, + ;; 'disk-partitions' could return partitions for which + ;; we have no /dev node. Handle that gracefully. + (if (= ENOENT (system-error-errno args)) + (begin + (format (current-error-port) + "warning: device '~a' not found~%" + device) + #f) + (apply throw args)))))) (and sblock (let ((volume (ext2-superblock-volume-name sblock))) (and volume -- cgit v1.2.3 From ac52e80b4e02718c9d040062c65f7df24302d226 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Jun 2014 21:48:57 +0200 Subject: linux-initrd: Make more device nodes for SCSI disks and CD-ROM devices. * guix/build/linux-initrd.scm (make-disk-device-nodes): New procedure. (make-essential-device-nodes): Use it. Make more devices nodes for SCSI disks and CD-ROM devices. --- guix/build/linux-initrd.scm | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 9a13e7213c..376242ce2b 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -211,6 +211,16 @@ (define (canonicalize-device-spec spec) spec (or (find-partition-by-label spec) spec))) +(define* (make-disk-device-nodes base major #:optional (minor 0)) + "Make the block device nodes around BASE (something like \"/root/dev/sda\") +with the given MAJOR number, starting with MINOR." + (mknod base 'block-special #o644 (device-number major minor)) + (let loop ((i 1)) + (when (< i 6) + (mknod (string-append base (number->string i)) + 'block-special #o644 (device-number major (+ minor i))) + (loop (+ i 1))))) + (define* (make-essential-device-nodes #:key (root "/")) "Make essential device nodes under ROOT/dev." ;; The hand-made udev! @@ -226,14 +236,17 @@ (define (scope dir) (mkdir (scope "dev"))) ;; Make the device nodes for SCSI disks. - (mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0)) - (mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1)) - (mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2)) + (make-disk-device-nodes (scope "dev/sda") 8) + (make-disk-device-nodes (scope "dev/sdb") 8 16) + (make-disk-device-nodes (scope "dev/sdc") 8 32) + (make-disk-device-nodes (scope "dev/sdd") 8 48) + + ;; SCSI CD-ROM devices (aka. "/dev/sr0" etc.). + (mknod (scope "dev/scd0") 'block-special #o644 (device-number 11 0)) + (mknod (scope "dev/scd1") 'block-special #o644 (device-number 11 1)) ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM. - (mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0)) - (mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1)) - (mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2)) + (make-disk-device-nodes (scope "dev/vda") 252) ;; Memory (used by Xorg's VESA driver.) (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1)) -- cgit v1.2.3 From 9b4a163a8763df80c18a44c505771d17ae8a25a3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Jun 2014 23:51:12 +0200 Subject: linux-initrd: Actually create /dev/console. * guix/build/linux-initrd.scm (make-essential-device-nodes): Add "dev/console". --- guix/build/linux-initrd.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 376242ce2b..d7de9c14ee 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -259,6 +259,12 @@ (define (scope dir) (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32)) (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64)) + ;; System console. This node is magically created by the kernel on the + ;; initrd's root, so don't try to create it in that case. + (unless (string=? root "/") + (mknod (scope "dev/console") 'char-special #o600 + (device-number 5 1))) + ;; TTYs. (mknod (scope "dev/tty") 'char-special #o600 (device-number 5 0)) -- cgit v1.2.3 From 2405858a0477aca880bb32c032df459de68e1bfd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 2 Jun 2014 23:48:55 +0200 Subject: linux-initrd: Wait for devices to appear when resolving a label. * guix/build/linux-initrd.scm (canonicalize-device-spec): Add #:title parameter. When resolving a label, wait a little and try several times before bailing out. --- guix/build/linux-initrd.scm | 50 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 44 insertions(+), 6 deletions(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index d7de9c14ee..05f6bf14bf 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -204,12 +204,50 @@ (define (find-partition-by-label label) (disk-partitions)) (cut string-append "/dev/" <>))) -(define (canonicalize-device-spec spec) - "Given SPEC, a string such as \"/dev/sda1\" or \"my-root-part\", return the -corresponding device name." - (if (string-prefix? "/" spec) - spec - (or (find-partition-by-label spec) spec))) +(define* (canonicalize-device-spec spec #:optional (title 'any)) + "Return the device name corresponding to SPEC. TITLE is a symbol, one of +the following: + + • 'device', in which case SPEC is known to designate a device node--e.g., + \"/dev/sda1\"; + • 'label', in which case SPEC is known to designate a partition label--e.g., + \"my-root-part\"; + • 'any', in which case SPEC can be anything. +" + (define max-trials + ;; Number of times we retry partition label resolution. + 7) + + (define canonical-title + ;; The realm of canonicalization. + (if (eq? title 'any) + (if (string-prefix? "/" spec) + 'device + 'label) + title)) + + (case canonical-title + ((device) + ;; Nothing to do. + spec) + ((label) + ;; Resolve the label. + (let loop ((count 0)) + (let ((device (find-partition-by-label spec))) + (or device + ;; Some devices take a bit of time to appear, most notably USB + ;; storage devices. Thus, wait for the device to appear. + (if (> count max-trials) + (begin + (format (current-error-port) + "failed to resolve partition label: ~s~%" spec) + (start-repl)) + (begin + (sleep 1) + (loop (+ 1 count)))))))) + ;; TODO: Add support for UUIDs. + (else + (error "unknown device title" title)))) (define* (make-disk-device-nodes base major #:optional (minor 0)) "Make the block device nodes around BASE (something like \"/root/dev/sda\") -- cgit v1.2.3 From d4c87617e5c0c50573019e4621ed318489cf209a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 2 Jun 2014 23:58:50 +0200 Subject: system: File system sources can be marked as labels or devices. * gnu/system/file-systems.scm ()[title]: New field. * gnu/services/base.scm (file-system-service): Add #:title parameter. In 'start' gexp, use 'canonicalize-device-spec' and honor TITLE. * gnu/system.scm (other-file-system-services, operating-system-root-file-system, operating-system-initrd-file): Adjust accordingly. * gnu/system/linux-initrd.scm (file-system->spec): Likewise. * gnu/system/vm.scm (system-disk-image): Add 'title' field for the root file system. * guix/build/linux-initrd.scm (mount-file-system): Expect the second element of SPEC to be the title. (boot-system)[root-mount-point?, root-fs-type]: Likewise. * gnu/services/dmd.scm (dmd-configuration-file): Select 'canonicalize-device-spec'. --- gnu/services/base.scm | 15 +++++++++------ gnu/services/dmd.scm | 2 +- gnu/system.scm | 11 +++++++---- gnu/system/file-systems.scm | 3 +++ gnu/system/linux-initrd.scm | 4 ++-- gnu/system/vm.scm | 1 + guix/build/linux-initrd.scm | 11 ++++++----- 7 files changed, 29 insertions(+), 18 deletions(-) (limited to 'guix/build') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3643f7cfc1..4442203524 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -89,9 +89,11 @@ (define (root-file-system-service) (respawn? #f))))) (define* (file-system-service device target type - #:key (check? #t) options) + #:key (check? #t) options (title 'any)) "Return a service that mounts DEVICE on TARGET as a file system TYPE with -OPTIONS. When CHECK? is true, check the file system before mounting it." +OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for +a partition label, 'device for a device file name, or 'any. When CHECK? is +true, check the file system before mounting it." (with-monad %store-monad (return (service @@ -99,10 +101,11 @@ (define* (file-system-service device target type (requirement '(root-file-system)) (documentation "Check, mount, and unmount the given file system.") (start #~(lambda args - #$(if check? - #~(check-file-system #$device #$type) - #~#t) - (mount #$device #$target #$type 0 #$options) + (let ((device (canonicalize-device-spec #$device '#$title))) + #$(if check? + #~(check-file-system device #$type) + #~#t) + (mount device #$target #$type 0 #$options)) #t)) (stop #~(lambda args ;; Normally there are no processes left at this point, so diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 982c196fe4..74adb27885 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -50,7 +50,7 @@ (define config (use-modules (ice-9 ftw) (guix build syscalls) ((guix build linux-initrd) - #:select (check-file-system))) + #:select (check-file-system canonicalize-device-spec))) (register-services #$@(map (lambda (service) diff --git a/gnu/system.scm b/gnu/system.scm index d05ec60b29..548184f5d5 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -182,8 +182,10 @@ (define file-systems (sequence %store-monad (map (match-lambda - (($ device target type flags opts #f check?) + (($ device title target type flags opts + #f check?) (file-system-service device target type + #:title title #:check? check? #:options opts))) file-systems))) @@ -449,7 +451,7 @@ (define (operating-system-boot-script os) (define (operating-system-root-file-system os) "Return the root file system of OS." (find (match-lambda - (($ _ "/") #t) + (($ _ _ "/") #t) (_ #f)) (operating-system-file-systems os))) @@ -457,9 +459,10 @@ (define (operating-system-initrd-file os) "Return a gexp denoting the initrd file of OS." (define boot-file-systems (filter (match-lambda - (($ device "/") + (($ device title "/") #t) - (($ device mount-point type flags options boot?) + (($ device title mount-point type flags + options boot?) boot?)) (operating-system-file-systems os))) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 485150ea51..7852a6ab26 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -22,6 +22,7 @@ (define-module (gnu system file-systems) file-system file-system? file-system-device + file-system-title file-system-mount-point file-system-type file-system-needed-for-boot? @@ -42,6 +43,8 @@ (define-record-type* file-system make-file-system file-system? (device file-system-device) ; string + (title file-system-title ; 'device | 'label | 'uuid + (default 'device)) (mount-point file-system-mount-point) ; string (type file-system-type) ; string (flags file-system-flags ; list of symbols diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index b80ff10f1e..17fec4f7f4 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -198,8 +198,8 @@ (define (file-system->spec fs) "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ device mount-point type flags options _ check?) - (list device mount-point type flags options check?)))) + (($ device title mount-point type flags options _ check?) + (list device title mount-point type flags options check?)))) (define* (qemu-initrd file-systems #:key diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 184f2512f1..c85445cd5f 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -290,6 +290,7 @@ (define file-systems-to-keep (file-systems (cons (file-system (mount-point "/") (device root-label) + (title 'label) (type file-system-type)) file-systems-to-keep))))) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 05f6bf14bf..c1a0247aff 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -37,6 +37,7 @@ (define-module (guix build linux-initrd) disk-partitions partition-label-predicate find-partition-by-label + canonicalize-device-spec check-file-system mount-file-system @@ -485,7 +486,7 @@ (define* (mount-file-system spec #:key (root "/root")) "Mount the file system described by SPEC under ROOT. SPEC must have the form: - (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) + (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to @@ -500,8 +501,8 @@ (define flags->bit-mask 0))) (match spec - ((source mount-point type (flags ...) options check?) - (let ((source (canonicalize-device-spec source)) + ((source title mount-point type (flags ...) options check?) + (let ((source (canonicalize-device-spec source title)) (mount-point (string-append root "/" mount-point))) (when check? (check-file-system source type)) @@ -596,12 +597,12 @@ (define (resolve file) (define root-mount-point? (match-lambda - ((device "/" _ ...) #t) + ((device _ "/" _ ...) #t) (_ #f))) (define root-fs-type (or (any (match-lambda - ((device "/" type _ ...) type) + ((device _ "/" type _ ...) type) (_ #f)) mounts) "ext4")) -- cgit v1.2.3 From 185f669109eb56b61c3d51dc8b2e3eeded9b2be9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Jun 2014 22:19:30 +0200 Subject: services: Make sure the store's group is the build group. * gnu/services/base.scm (guix-service)[activate]: New variable. Add 'chown' call for (%store-prefix). Set the 'activate' field to ACTIVATE. * guix/build/install.scm (directives): Add comment about STORE's group. --- gnu/services/base.scm | 18 +++++++++++++++--- guix/build/install.scm | 5 ++++- 2 files changed, 19 insertions(+), 4 deletions(-) (limited to 'guix/build') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3f7f453c9b..94fa919c0f 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -17,6 +17,8 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu services base) + #:use-module ((guix store) + #:select (%store-prefix)) #:use-module (gnu services) #:use-module (gnu system shadow) ; 'user-account', etc. #:use-module (gnu system linux) ; 'pam-service', etc. @@ -348,7 +350,6 @@ (define (hydra-key-authorization guix) (port (open-file key "r0b"))) (format #t "registering public key '~a'...~%" key) (close-port (current-input-port)) - ;; (close-fdes 0) (dup port 0) (execl (string-append #$guix "/bin/guix") "guix" "archive" "--authorize") @@ -367,6 +368,18 @@ (define* (guix-service #:key (guix guix) (builder-group "guixbuild") When AUTHORIZE-HYDRA-KEY? is true, the hydra.gnu.org public key provided by GUIX is authorized upon activation, meaning that substitutes from hydra.gnu.org are used by default." + (define activate + #~(begin + ;; Make sure the store has BUILDER-GROUP as its group. This may fail + ;; with EACCES when the store is a 9p mount, so catch exceptions. + (false-if-exception + (chown #$(%store-prefix) 0 + (group:gid (getgrnam #$builder-group)))) + + ;; Optionally authorize hydra.gnu.org's key. + #$(and authorize-hydra-key? + (hydra-key-authorization guix)))) + (mlet %store-monad ((accounts (guix-build-accounts build-accounts #:group builder-group))) (return (service @@ -383,8 +396,7 @@ (define* (guix-service #:key (guix guix) (builder-group "guixbuild") (name builder-group) (members (map user-account-name user-accounts))))) - (activate (and authorize-hydra-key? - (hydra-key-authorization guix))))))) + (activate activate))))) (define %base-services ;; Convenience variable holding the basic services. diff --git a/guix/build/install.scm b/guix/build/install.scm index afa7d1dd8f..ea787b63e2 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -73,7 +73,10 @@ (define (evaluate-populate-directive directive target) (define (directives store) "Return a list of directives to populate the root file system that will host STORE." - `((directory ,store 0 0) + `(;; Note: The store's group is changed to the "guixbuild" group at + ;; activation time. + (directory ,store 0 0) + (directory "/etc") (directory "/var/log") ; for dmd (directory "/var/guix/gcroots") -- cgit v1.2.3 From e2fcc23a3a562b9efa55530f442bba4bd0436d4f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Jun 2014 23:08:09 +0200 Subject: activation: Only create groups that do not exist yet. Before that the effect would be to re-create groups at each boot, and thus remove any members of the groups. * guix/build/activation.scm (activate-users+groups): Call 'add-group' only when (getgrname name) fails. --- guix/build/activation.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 62e69a9152..bc62a94e01 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -126,7 +126,8 @@ (define activate-user ;; Then create the groups. (for-each (match-lambda ((name password gid) - (add-group name #:gid gid #:password password))) + (unless (false-if-exception (getgrnam name)) + (add-group name #:gid gid #:password password)))) groups) ;; Finally create the other user accounts. -- cgit v1.2.3 From e97c5be914864674d024dd088eb1f2788ac49f46 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 Jun 2014 00:09:12 +0200 Subject: services: Use a fixed GID for the build group and use that for the store. This partly reverts commit 185f669 ("services: Make sure the store's group is the build group.") * gnu/services/base.scm (guix-service)[activate]: Remove 'chown' call. Add 'id' field to 'user-group' form. * guix/build/install.scm (directives): Set the store's GID to 30000. --- gnu/services/base.scm | 21 +++++++++++---------- guix/build/install.scm | 6 +++--- 2 files changed, 14 insertions(+), 13 deletions(-) (limited to 'guix/build') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 94fa919c0f..65a8ceefc4 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -369,16 +369,13 @@ (define* (guix-service #:key (guix guix) (builder-group "guixbuild") GUIX is authorized upon activation, meaning that substitutes from hydra.gnu.org are used by default." (define activate - #~(begin - ;; Make sure the store has BUILDER-GROUP as its group. This may fail - ;; with EACCES when the store is a 9p mount, so catch exceptions. - (false-if-exception - (chown #$(%store-prefix) 0 - (group:gid (getgrnam #$builder-group)))) + ;; Assume that the store has BUILDER-GROUP as its group. We could + ;; otherwise call 'chown' here, but the problem is that on a COW unionfs, + ;; chown leads to an entire copy of the tree, which is a bad idea. - ;; Optionally authorize hydra.gnu.org's key. - #$(and authorize-hydra-key? - (hydra-key-authorization guix)))) + ;; Optionally authorize hydra.gnu.org's key. + (and authorize-hydra-key? + (hydra-key-authorization guix))) (mlet %store-monad ((accounts (guix-build-accounts build-accounts #:group builder-group))) @@ -395,7 +392,11 @@ (define activate (user-groups (list (user-group (name builder-group) (members (map user-account-name - user-accounts))))) + user-accounts)) + + ;; Use a fixed GID so that we can create the + ;; store with the right owner. + (id 30000)))) (activate activate))))) (define %base-services diff --git a/guix/build/install.scm b/guix/build/install.scm index ea787b63e2..2a76394faa 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -73,9 +73,9 @@ (define (evaluate-populate-directive directive target) (define (directives store) "Return a list of directives to populate the root file system that will host STORE." - `(;; Note: The store's group is changed to the "guixbuild" group at - ;; activation time. - (directory ,store 0 0) + `(;; Note: the store's GID is fixed precisely so we can set it here rather + ;; than at activation time. + (directory ,store 0 30000) (directory "/etc") (directory "/var/log") ; for dmd -- cgit v1.2.3