Merge branch 'master' into core-updates

7 files changed, 276 insertions, 33 deletions

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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; 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
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.
diff --git a/guix/build/install.scm b/guix/build/install.scm
index afa7d1dd8f..2a76394faa 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 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
     (directory "/var/guix/gcroots")
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 5be3c1ac2a..c1a0247aff 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,16 @@
             find-long-option
             make-essential-device-nodes
             configure-qemu-networking
+
+            disk-partitions
+            partition-label-predicate
+            find-partition-by-label
+            canonicalize-device-spec
+
             check-file-system
             mount-file-system
             bind-mount
+
             load-linux-module*
             device-number
             boot-system))
@@ -88,6 +97,169 @@ 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
+;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
+;; 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 (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
+                  (string=? volume 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 #: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\")
+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!
@@ -103,14 +275,17 @@ Return the value associated with OPTION, or #f on failure."
     (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))
@@ -123,6 +298,12 @@ Return the value associated with OPTION, or #f on failure."
   (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))
@@ -305,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
@@ -320,8 +501,9 @@ run a file system check."
       0)))
 
   (match spec
-    ((source mount-point type (flags ...) options check?)
-     (let ((mount-point (string-append root "/" mount-point)))
+    ((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))
        (mkdir-p mount-point)
@@ -381,6 +563,7 @@ bailing out.~%root contents: ~s~%" (scandir "/"))
 
       (close-port console))))
 
+
 (define* (boot-system #:key
                       (linux-modules '())
                       qemu-guest-networking?
@@ -414,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"))
@@ -451,7 +634,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"))
 
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)                             ; <sys/mounts.h> 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)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 09b7ec079e..5ca516aa28 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
 <derivation> 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 <> " " <>)
@@ -955,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)
@@ -974,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)))
 
@@ -1100,4 +1108,5 @@ LOCAL-BUILD?."
                 #:recursive? recursive?
                 #:outputs outputs
                 #:references-graphs references-graphs
+                #:allowed-references allowed-references
                 #:local-build? local-build?)))
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))