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') 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 @@ REFERENCE-GRAPHS, a list of reference-graph files." (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 @@ REFERENCE-GRAPHS, a list of reference-graph files." 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 @@ true, copy all of CLOSURES to the 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') 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 @@ 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 @@ Return the value associated with OPTION, or #f on failure." (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 @@ run a file system check." (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 @@ bailing out.~%root contents: ~s~%" (scandir "/")) (close-port console)))) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? @@ -451,7 +562,8 @@ to it are lost." (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') 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 @@ return #t if that partition's volume name is 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') 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 @@ if DEVICE does not contain an ext2 file system." 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') 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 @@ corresponding device name." 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 @@ corresponding device name." (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 b53be755e465be04dc05e9069178874cb9f1f44d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Jun 2014 23:32:26 +0200 Subject: derivations: Add #:allowed-references 'derivation' parameter. * guix/derivations.scm (derivation): Add #:allowed-references parameter. [user+system-env-vars]: Honor it. * tests/derivations.scm ("derivation #:allowed-references, ok", "derivation #:allowed-references, not allowed", "derivation #:allowed-references, self allowed", "derivation #:allowed-references, self not allowed"): New tests. * doc/guix.texi (Derivations): Document #:allowed-references. --- doc/guix.texi | 5 ++++- guix/derivations.scm | 17 ++++++++++++----- tests/derivations.scm | 37 +++++++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index eeadb04d78..cfdfcd8b78 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1737,7 +1737,7 @@ a derivation is the @code{derivation} procedure: @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ [#:recursive? #f] [#:inputs '()] [#:env-vars '()] @ [#:system (%current-system)] [#:references-graphs #f] @ - [#:local-build? #f] + [#:allowed-references #f] [#:local-build? #f] Build a derivation with the given arguments, and return the resulting @code{} object. @@ -1753,6 +1753,9 @@ name/store path pairs. In that case, the reference graph of each store path is exported in the build environment in the corresponding file, in a simple text format. +When @var{allowed-references} is true, it must be a list of store items +or outputs that the derivation's output may refer to. + When @var{local-build?} is true, declare that the derivation is not a good candidate for offloading and should rather be built locally (@pxref{Daemon Offload Setup}). This is the case for small derivations diff --git a/guix/derivations.scm b/guix/derivations.scm index 09b7ec079e..8d0c9c08df 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -565,7 +565,7 @@ HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for (system (%current-system)) (env-vars '()) (inputs '()) (outputs '("out")) hash hash-algo recursive? - references-graphs + references-graphs allowed-references local-build?) "Build a derivation with the given arguments, and return the resulting object. When HASH and HASH-ALGO are given, a @@ -578,6 +578,9 @@ When REFERENCES-GRAPHS is true, it must be a list of file name/store path pairs. In that case, the reference graph of each store path is exported in the build environment in the corresponding file, in a simple text format. +When ALLOWED-REFERENCES is true, it must be a list of store items or outputs +that the derivation's output may refer to. + When LOCAL-BUILD? is true, declare that the derivation is not a good candidate for offloading and should rather be built locally. This is the case for small derivations where the costs of data transfers would outweigh the benefits." @@ -615,10 +618,14 @@ derivations where the costs of data transfers would outweigh the benefits." ;; Some options are passed to the build daemon via the env. vars of ;; derivations (urgh!). We hide that from our API, but here is the place ;; where we kludgify those options. - (let ((env-vars (if local-build? - `(("preferLocalBuild" . "1") - ,@env-vars) - env-vars))) + (let ((env-vars `(,@(if local-build? + `(("preferLocalBuild" . "1")) + '()) + ,@(if allowed-references + `(("allowedReferences" + . ,(string-join allowed-references))) + '()) + ,@env-vars))) (match references-graphs (((file . path) ...) (let ((value (map (cut string-append <> " " <>) diff --git a/tests/derivations.scm b/tests/derivations.scm index 0b785029a7..87609108d6 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -390,6 +390,43 @@ ((p2 . _) (string $out") + #:inputs `((,%bash)) + #:allowed-references '()))) + (build-derivations %store (list drv)))) + +(test-assert "derivation #:allowed-references, not allowed" + (let* ((txt (add-text-to-store %store "foo" "Hello, world.")) + (drv (derivation %store "disallowed" %bash + `("-c" ,(string-append "echo " txt "> $out")) + #:inputs `((,%bash) (,txt)) + #:allowed-references '()))) + (guard (c ((nix-protocol-error? c) + ;; There's no specific error message to check for. + #t)) + (build-derivations %store (list drv)) + #f))) + +(test-assert "derivation #:allowed-references, self allowed" + (let ((drv (derivation %store "allowed" %bash + '("-c" "echo $out > $out") + #:inputs `((,%bash)) + #:allowed-references '("out")))) + (build-derivations %store (list drv)))) + +(test-assert "derivation #:allowed-references, self not allowed" + (let ((drv (derivation %store "disallowed" %bash + `("-c" ,"echo $out > $out") + #:inputs `((,%bash)) + #:allowed-references '()))) + (guard (c ((nix-protocol-error? c) + ;; There's no specific error message to check for. + #t)) + (build-derivations %store (list drv)) + #f))) + (define %coreutils (false-if-exception -- 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') 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 @@ with the given MAJOR number, starting with MINOR." (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') 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 @@ were found." (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') 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 @@ This service must be the root of the service dependency graph so that its (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 @@ OPTIONS. When CHECK? is true, check the file system before mounting it." (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 @@ (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 @@ as 'needed-for-boot'." (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 @@ we're running in the final root." (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 @@ we're running in the final root." "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 @@ 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 @@ 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 @@ a list of Guile module names to be embedded in the initrd." "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 @@ to USB sticks meant to be read-only." (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 @@ disk-partitions partition-label-predicate find-partition-by-label + canonicalize-device-spec check-file-system mount-file-system @@ -485,7 +486,7 @@ UNIONFS." "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 @@ run a file system check." 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 @@ to it are lost." (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 c17b5ab4db140f142f38cdc99468e63e66c91912 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Jun 2014 17:26:54 +0200 Subject: tests: Skip tests that would hit the shebang length limitation. * tests/gexp.scm (shebang): New variable. Skip "gexp->script" when SHEBANG is longer than 127 chars. * guix/gexp.scm (gexp->script): Add comment on the issue. --- guix/gexp.scm | 4 ++++ tests/gexp.scm | 8 ++++++++ 2 files changed, 12 insertions(+) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index a2ba50d957..3b154d400f 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -351,6 +351,10 @@ its search path." (gexp (call-with-output-file (ungexp output) (lambda (port) + ;; Note: that makes a long shebang. When the store + ;; is /gnu/store, that fits within the 128-byte + ;; limit imposed by Linux, but that may go beyond + ;; when running tests. (format port "#!~a/bin/guile --no-auto-compile~%!#~%" (ungexp guile)) diff --git a/tests/gexp.scm b/tests/gexp.scm index 21606b510b..60adf497ed 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -211,6 +211,14 @@ (return (string=? (readlink (string-append out "/foo")) guile)))) +(define shebang + (string-append (derivation->output-path guile-for-build) + "/bin/guile --no-auto-compile")) + +;; If we're going to hit the silly shebang limit (128 chars on Linux-based +;; systems), then skip the following test. +(test-skip (if (> (string-length shebang) 127) 1 0)) + (test-assertm "gexp->script" (mlet* %store-monad ((n -> (random (expt 2 50))) (exp -> (gexp -- 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') 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 @@ 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 @@ BUILD-ACCOUNTS user accounts available under BUILD-USER-GID. 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 @@ hydra.gnu.org are used by default." (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 @@ directory 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') 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 @@ numeric gid or #f." ;; 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') 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 @@ 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)))) + ;; 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 @@ hydra.gnu.org are used by default." (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 @@ directory 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 From 63a428246825e83c8d6a8ff181658ee0a81184d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 Jun 2014 17:07:26 +0200 Subject: derivations: 'build-expression->derivation' supports #:allowed-references. * guix/derivations.scm (build-expression->derivation): Add #:allowed-references and pass it to 'derivation. * doc/guix.texi (Derivations): Adjust accordingly. --- doc/guix.texi | 7 ++++--- guix/derivations.scm | 6 ++++-- 2 files changed, 8 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 4d5a5150e6..10eb344c71 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1798,7 +1798,8 @@ is now deprecated in favor of the much nicer @code{gexp->derivation}. [#:system (%current-system)] [#:inputs '()] @ [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ - [#:references-graphs #f] [#:local-build? #f] [#:guile-for-build #f] + [#:references-graphs #f] [#:allowed-references #f] @ + [#:local-build? #f] [#:guile-for-build #f] Return a derivation that executes Scheme expression @var{exp} as a builder for derivation @var{name}. @var{inputs} must be a list of @code{(name drv-path sub-drv)} tuples; when @var{sub-drv} is omitted, @@ -1820,8 +1821,8 @@ terminates by passing the result of @var{exp} to @code{exit}; thus, when @var{guile-for-build} is omitted or is @code{#f}, the value of the @code{%guile-for-build} fluid is used instead. -See the @code{derivation} procedure for the meaning of @var{references-graphs} -and @var{local-build?}. +See the @code{derivation} procedure for the meaning of +@var{references-graphs}, @var{allowed-references}, and @var{local-build?}. @end deffn @noindent diff --git a/guix/derivations.scm b/guix/derivations.scm index 8d0c9c08df..5ca516aa28 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -962,6 +962,7 @@ they can refer to each other." (modules '()) guile-for-build references-graphs + allowed-references local-build?) "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) @@ -981,8 +982,8 @@ EXP returns #f, the build is considered to have failed. EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is omitted or is #f, the value of the `%guile-for-build' fluid is used instead. -See the `derivation' procedure for the meaning of REFERENCES-GRAPHS and -LOCAL-BUILD?." +See the `derivation' procedure for the meaning of REFERENCES-GRAPHS, +ALLOWED-REFERENCES, and LOCAL-BUILD?." (define guile-drv (or guile-for-build (%guile-for-build))) @@ -1107,4 +1108,5 @@ LOCAL-BUILD?." #:recursive? recursive? #:outputs outputs #:references-graphs references-graphs + #:allowed-references allowed-references #:local-build? local-build?))) -- cgit v1.2.3 From b15d79dfe65353f4101b0ad653c97e3ef0d4a8b7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 Jun 2014 17:18:17 +0200 Subject: build-system/gnu: Add #:allowed-references. * guix/build-system/gnu.scm (gnu-build): Add #:allowed-references. [canonicalize-reference]: New procedure. Pass #:allowed-references to 'build-expression->derivation'. (gnu-cross-build): Likewise. --- guix/build-system/gnu.scm | 41 +++++++++++++++++++++++++++++++++++++---- 1 file changed, 37 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index a50ca134f2..0c3f1ea4e3 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -265,7 +265,8 @@ System: GCC, GNU Make, Bash, Coreutils, etc." (system (%current-system)) (implicit-inputs? #t) ; useful when bootstrapping (imported-modules %default-modules) - (modules %default-modules)) + (modules %default-modules) + allowed-references) "Return a derivation called NAME that builds from tarball SOURCE, with input derivation INPUTS, using the usual procedure of the GNU Build System. The builder is run with GUILE, or with the distro's final Guile @@ -276,7 +277,10 @@ specifies modules not provided by Guile itself that must be imported in the builder's environment, from the host. Note that we distinguish between both, because for Guile's own modules like (ice-9 foo), we want to use GUILE's own version of it, rather than import the user's one, -which could lead to gratuitous input divergence." +which could lead to gratuitous input divergence. + +ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs +are allowed to refer to." (define implicit-inputs (and implicit-inputs? (parameterize ((%store store)) @@ -287,6 +291,16 @@ which could lead to gratuitous input divergence." (standard-search-paths) '())) + (define canonicalize-reference + (match-lambda + ((? package? p) + (derivation->output-path (package-derivation store p system))) + (((? package? p) output) + (derivation->output-path (package-derivation store p system) + output)) + ((? string? output) + output))) + (define builder `(begin (use-modules ,@modules) @@ -337,6 +351,10 @@ which could lead to gratuitous input divergence." outputs (delete "debug" outputs)) #:modules imported-modules + #:allowed-references + (and allowed-references + (map canonicalize-reference + allowed-references)) #:guile-for-build guile-for-build)) @@ -403,7 +421,8 @@ inputs." (imported-modules '((guix build gnu-build-system) (guix build utils))) (modules '((guix build gnu-build-system) - (guix build utils)))) + (guix build utils))) + allowed-references) "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are cross-built inputs, and NATIVE-INPUTS are inputs that run on the build platform." @@ -428,6 +447,16 @@ platform." (standard-cross-search-paths target 'target) '())) + (define canonicalize-reference + (match-lambda + ((? package? p) + (derivation->output-path (package-cross-derivation store p system))) + (((? package? p) output) + (derivation->output-path (package-cross-derivation store p system) + output)) + ((? string? output) + output))) + (define builder `(begin (use-modules ,@modules) @@ -512,6 +541,10 @@ platform." outputs (delete "debug" outputs)) #:modules imported-modules + #:allowed-references + (and allowed-references + (map canonicalize-reference + allowed-references)) #:guile-for-build guile-for-build)) (define gnu-build-system -- cgit v1.2.3