Merge branch 'master' into staging

10 files changed, 212 insertions, 89 deletions

diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl
index 7e0c8fbee0..cb6d2623db 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -16,8 +16,7 @@
                 (bootloader grub-bootloader)
                 (target "/dev/sdX")))
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl
index 97201330c7..d1130c76b6 100644
--- a/gnu/system/examples/beaglebone-black.tmpl
+++ b/gnu/system/examples/beaglebone-black.tmpl
@@ -20,8 +20,7 @@
   (initrd-modules (cons "omap_hsmmc" %base-initrd-modules))
 
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl
index 65a8ee1809..360ee62ffe 100644
--- a/gnu/system/examples/lightweight-desktop.tmpl
+++ b/gnu/system/examples/lightweight-desktop.tmpl
@@ -20,13 +20,11 @@
   ;; Assume the target root file system is labelled "my-root",
   ;; and the EFI System Partition has UUID 1234-ABCD.
   (file-systems (cons* (file-system
-                         (device "my-root")
-                         (title 'label)
+                         (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        (file-system
                          (device (uuid "1234-ABCD" 'fat))
-                         (title 'uuid)
                          (mount-point "/boot/efi")
                          (type "vfat"))
                        %base-file-systems))
diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl
index ce3653c8b4..36e272722d 100644
--- a/gnu/system/examples/vm-image.tmpl
+++ b/gnu/system/examples/vm-image.tmpl
@@ -31,8 +31,7 @@ partprobe, and then 2) resizing the filesystem with resize2fs.\n"))
                (target "/dev/sda")
                (terminal-outputs '(console))))
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index d2acd705de..2b5948256a 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,16 +20,17 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (guix records)
   #:use-module (gnu system uuid)
   #:re-export (uuid                               ;backward compatibility
                string->uuid
                uuid->string)
-  #:export (<file-system>
-            file-system
+  #:export (file-system
             file-system?
             file-system-device
-            file-system-title
+            file-system-title                     ;deprecated
             file-system-mount-point
             file-system-type
             file-system-needed-for-boot?
@@ -43,6 +44,10 @@
 
             file-system-type-predicate
 
+            file-system-label
+            file-system-label?
+            file-system-label->string
+
             file-system->spec
             spec->file-system
             specification->file-system-mapping
@@ -83,12 +88,10 @@
 ;;; Code:
 
 ;; File system declaration.
-(define-record-type* <file-system> file-system
+(define-record-type* <file-system> %file-system
   make-file-system
   file-system?
-  (device           file-system-device)           ; string
-  (title            file-system-title             ; 'device | 'label | 'uuid
-                    (default 'device))
+  (device           file-system-device) ; string | <uuid> | <file-system-label>
   (mount-point      file-system-mount-point)      ; string
   (type             file-system-type)             ; string
   (flags            file-system-flags             ; list of symbols
@@ -109,6 +112,83 @@
                     (default (current-source-location))
                     (innate)))
 
+;; A file system label for use in the 'device' field.
+(define-record-type <file-system-label>
+  (file-system-label label)
+  file-system-label?
+  (label file-system-label->string))
+
+(set-record-type-printer! <file-system-label>
+                          (lambda (obj port)
+                            (format port "#<file-system-label ~s>"
+                                    (file-system-label->string obj))))
+
+(define-syntax report-deprecation
+  (lambda (s)
+    "Report the use of the now-deprecated 'title' field."
+    (syntax-case s ()
+      ((_ field)
+       (let* ((source (syntax-source #'field))
+              (file   (and source (assq-ref source 'filename)))
+              (line   (and source
+                           (and=> (assq-ref source 'line) 1+)))
+              (column (and source (assq-ref source 'column))))
+         (format (current-error-port)
+                 "~a:~a:~a: warning: 'title' field is deprecated~%"
+                 file line column)
+         #t)))))
+
+;; Helper for 'process-file-system-declaration'.
+(define-syntax device-expression
+  (syntax-rules (quote label uuid device)
+    ((_ (quote label) dev)
+     (file-system-label dev))
+    ((_ (quote uuid) dev)
+     (if (uuid? dev) dev (uuid dev)))
+    ((_ (quote device) dev)
+     dev)
+    ((_ title dev)
+     (case title
+       ((label) (file-system-label dev))
+       ((uuid)  (uuid dev))
+       (else    dev)))))
+
+;; Helper to interpret the now-deprecated 'title' field.  Detect forms like
+;; (title 'label), remove them, and adjust the 'device' field accordingly.
+;; TODO: Remove this once 'title' has been deprecated long enough.
+(define-syntax process-file-system-declaration
+  (syntax-rules (device title)
+    ((_ () (rest ...) #f #f)                 ;no 'title' and no 'device' field
+     (%file-system rest ...))
+    ((_ () (rest ...) dev #f)                     ;no 'title' field
+     (%file-system rest ... (device dev)))
+    ((_ () (rest ...) dev titl)                   ;got a 'title' field
+     (%file-system rest ...
+                   (device (device-expression titl dev))))
+    ((_ ((title titl) rest ...) (previous ...) dev _)
+     (begin
+       (report-deprecation (title titl))
+       (process-file-system-declaration (rest ...)
+                                        (previous ...)
+                                        dev titl)))
+    ((_ ((device dev) rest ...) (previous ...) _ titl)
+     (process-file-system-declaration (rest ...)
+                                      (previous ...)
+                                      dev titl))
+    ((_ (field rest ...) (previous ...) dev titl)
+     (process-file-system-declaration (rest ...)
+                                      (previous ... field)
+                                      dev titl))))
+
+(define-syntax-rule (file-system fields ...)
+  (process-file-system-declaration (fields ...) () #f #f))
+
+(define (file-system-title fs)                    ;deprecated
+  (match (file-system-device fs)
+    ((? file-system-label?) 'label)
+    ((? uuid?)              'uuid)
+    ((? string?)            'device)))
+
 ;; Note: This module is used both on the build side and on the host side.
 ;; Arrange not to pull (guix store) and (guix config) because the latter
 ;; differs from user to user.
@@ -161,23 +241,26 @@ store--e.g., if FS is the root file system."
   "Return a list corresponding to file-system FS that can be passed to the
 initrd code."
   (match fs
-    (($ <file-system> device title mount-point type flags options _ _ check?)
-     (list (if (uuid? device)
-               `(uuid ,(uuid-type device) ,(uuid-bytevector device))
-               device)
-           title mount-point type flags options check?))))
+    (($ <file-system> device mount-point type flags options _ _ check?)
+     (list (cond ((uuid? device)
+                  `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
+                 ((file-system-label? device)
+                  `(file-system-label ,(file-system-label->string device)))
+                 (else device))
+           mount-point type flags options check?))))
 
 (define (spec->file-system sexp)
   "Deserialize SEXP, a list, to the corresponding <file-system> object."
   (match sexp
-    ((device title mount-point type flags options check?)
+    ((device mount-point type flags options check?)
      (file-system
        (device (match device
                  (('uuid (? symbol? type) (? bytevector? bv))
                   (bytevector->uuid bv type))
+                 (('file-system-label (? string? label))
+                  (file-system-label label))
                  (_
                   device)))
-       (title title)
        (mount-point mount-point) (type type)
        (flags flags) (options options)
        (check? check?)))))
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 920d215272..35f4ba9c24 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -49,7 +49,12 @@
             a20-olinuxino-micro-installation-os
             banana-pi-m2-ultra-installation-os
             beaglebone-black-installation-os
-            nintendo-nes-classic-edition-installation-os))
+            mx6cuboxi-installation-os
+            nintendo-nes-classic-edition-installation-os
+            novena-installation-os
+            pine64-plus-installation-os
+            rk3399-puma-installation-os
+            wandboard-installation-os))
 
 ;;; Commentary:
 ;;;
@@ -324,8 +329,7 @@ You have been warned.  Thanks for being so brave.\x1b[0m
      ;; the appropriate one.
      (cons* (file-system
               (mount-point "/")
-              (device "GuixSD_image")
-              (title 'label)
+              (device (file-system-label "GuixSD_image"))
               (type "ext4"))
 
             ;; Make /tmp a tmpfs instead of keeping the overlayfs.  This
@@ -337,7 +341,6 @@ You have been warned.  Thanks for being so brave.\x1b[0m
             (file-system
               (mount-point "/tmp")
               (device "none")
-              (title 'device)
               (type "tmpfs")
               (check? #f))
 
@@ -429,11 +432,36 @@ The bootloader BOOTLOADER is installed to BOOTLOADER-TARGET."
                             "/dev/mmcblk1" ; eMMC storage
                             "ttyS0"))
 
+(define mx6cuboxi-installation-os
+  (embedded-installation-os u-boot-mx6cuboxi-bootloader
+                            "/dev/mmcblk0" ; SD card storage
+                            "ttymxc0"))
+
+(define novena-installation-os
+  (embedded-installation-os u-boot-novena-bootloader
+                            "/dev/mmcblk1" ; SD card storage
+                            "ttymxc1"))
+
 (define nintendo-nes-classic-edition-installation-os
   (embedded-installation-os u-boot-nintendo-nes-classic-edition-bootloader
                             "/dev/mmcblk0" ; SD card (solder it yourself)
                             "ttyS0"))
 
+(define pine64-plus-installation-os
+  (embedded-installation-os u-boot-pine64-plus-bootloader
+                            "/dev/mmcblk0" ; SD card storage
+                            "ttyS0"))
+
+(define rk3399-puma-installation-os
+  (embedded-installation-os u-boot-puma-rk3399-bootloader
+                            "/dev/mmcblk0" ; SD card storage
+                            "ttyS0"))
+
+(define wandboard-installation-os
+  (embedded-installation-os u-boot-wandboard-bootloader
+                            "/dev/mmcblk0" ; SD card storage
+                            "ttymxc0"))
+
 ;; Return the default os here so 'guix system' can consume it directly.
 installation-os
 
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index e0cb59c009..d73ebfd8d3 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -283,7 +283,7 @@ FILE-SYSTEMS."
   (define virtio-modules
     ;; Modules for Linux para-virtualized devices, for use in QEMU guests.
     '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
-      "virtio_console"))
+      "virtio_console" "virtio-rng"))
 
   `("ahci"                                  ;for SATA controllers
     "usb-storage" "uas"                     ;for the installation image etc.
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index ef5b8dab92..28d399f2b1 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -168,6 +168,9 @@ then
     return
 fi
 
+# Source the system-wide file.
+source /etc/bashrc
+
 # Adjust the prompt depending on whether we're in 'guix environment'.
 if [ -n \"$GUIX_ENVIRONMENT\" ]
 then
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index 73695ddeb8..f13960c3e9 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -251,7 +251,8 @@ corresponding bytevector; otherwise return #f."
 
 (define-syntax uuid
   (lambda (s)
-    "Return the UUID object corresponding to the given UUID representation."
+    "Return the UUID object corresponding to the given UUID representation or
+#f if the string could not be parsed."
     (syntax-case s (quote)
       ((_ str (quote type))
        (and (string? (syntax->datum #'str))
@@ -266,9 +267,11 @@ corresponding bytevector; otherwise return #f."
        (string? (syntax->datum #'str))
        #'(uuid str 'dce))
       ((_ str)
-       #'(make-uuid 'dce (string->uuid str 'dce)))
+       #'(let ((bv (string->uuid str 'dce)))
+           (and bv (make-uuid 'dce bv))))
       ((_ str type)
-       #'(make-uuid type (string->uuid str type))))))
+       #'(let ((bv (string->uuid str type)))
+           (and bv (make-uuid type bv)))))))
 
 (define uuid->string
   ;; Convert the given bytevector or UUID object, to the corresponding UUID
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 09a11af863..544c0e294d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,7 +23,6 @@
 
 (define-module (gnu system vm)
   #:use-module (guix config)
-  #:use-module (guix docker)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -126,6 +125,8 @@
                                              (env-vars '())
                                              (guile-for-build
                                               (%guile-for-build))
+                                             (file-systems
+                                              %linux-vm-file-systems)
 
                                              (single-file-output? #f)
                                              (make-disk-image? #f)
@@ -135,8 +136,9 @@
                                              (disk-image-size 'guess))
   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
 derivation).  The virtual machine runs with MEMORY-SIZE MiB of memory.  In the
-virtual machine, EXP has access to all its inputs from the store; it should
-put its output file(s) in the '/xchg' directory.
+virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
+9p share of the store, the '/xchg' where EXP should put its output file(s),
+and a 9p share of /tmp.
 
 If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
 Otherwise, copy the contents of /xchg to a new directory OUTPUT.
@@ -156,7 +158,7 @@ made available under the /xchg CIFS share."
        (coreutils -> (canonical-package coreutils))
        (initrd       (if initrd                   ; use the default initrd?
                          (return initrd)
-                         (base-initrd %linux-vm-file-systems
+                         (base-initrd file-systems
                                       #:on-error 'backtrace
                                       #:linux linux
                                       #:linux-modules %base-initrd-modules
@@ -258,6 +260,14 @@ INPUTS is a list of inputs (as for packages)."
                                                       uuid-bytevector))
            (reboot))))
    #:system system
+
+   ;; Keep a local file system for /tmp so that we can populate it directly as
+   ;; root and have files owned by root.  See <https://bugs.gnu.org/31752>.
+   #:file-systems (remove (lambda (file-system)
+                            (string=? (file-system-mount-point file-system)
+                                      "/tmp"))
+                          %linux-vm-file-systems)
+
    #:make-disk-image? #f
    #:single-file-output? #t
    #:references-graphs inputs))
@@ -411,58 +421,57 @@ should set REGISTER-CLOSURES? to #f."
                      (eval-when (expand load eval)
                        (define %libgcrypt
                          #+(file-append libgcrypt "/lib/libgcrypt"))))))
+
   (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
                       (name -> (string-append name ".tar.gz"))
                       (graph -> "system-graph"))
     (define build
-      (with-imported-modules `(,@(source-module-closure '((guix docker)
-                                                          (guix build utils)
-                                                          (gnu build vm))
-                                                        #:select? not-config?)
-                               (guix build store-copy)
-                               ((guix config) => ,config))
-        #~(begin
-            ;; Guile-JSON is required by (guix docker).
-            (add-to-load-path
-             (string-append #+guile-json "/share/guile/site/"
-                            (effective-version)))
-            (use-modules (guix docker)
-                         (guix build utils)
-                         (gnu build vm)
-                         (srfi srfi-19)
-                         (guix build store-copy))
-
-            (let* ((inputs '#$(append (list tar)
-                                      (if register-closures?
-                                          (list guix)
-                                          '())))
-                   ;; This initializer requires elevated privileges that are
-                   ;; not normally available in the build environment (e.g.,
-                   ;; it needs to create device nodes).  In order to obtain
-                   ;; such privileges, we run it as root in a VM.
-                   (initialize (root-partition-initializer
-                                #:closures '(#$graph)
-                                #:register-closures? #$register-closures?
-                                #:system-directory #$os-drv
-                                ;; De-duplication would fail due to
-                                ;; cross-device link errors, so don't do it.
-                                #:deduplicate? #f))
-                   ;; Even as root in a VM, the initializer would fail due to
-                   ;; lack of privileges if we use a root-directory that is on
-                   ;; a file system that is shared with the host (e.g., /tmp).
-                   (root-directory "/guixsd-system-root"))
-              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-              (mkdir root-directory)
-              (initialize root-directory)
-              (build-docker-image
-               (string-append "/xchg/" #$name) ;; The output file.
-               (cons* root-directory
-                      (call-with-input-file (string-append "/xchg/" #$graph)
-                        read-reference-graph))
-               #$os-drv
-               #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
-               #:creation-time (make-time time-utc 0 1)
-               #:transformations `((,root-directory -> "")))))))
+      (with-extensions (list guile-json)          ;for (guix docker)
+        (with-imported-modules `(,@(source-module-closure
+                                    '((guix docker)
+                                      (guix build utils)
+                                      (gnu build vm))
+                                    #:select? not-config?)
+                                 (guix build store-copy)
+                                 ((guix config) => ,config))
+          #~(begin
+              (use-modules (guix docker)
+                           (guix build utils)
+                           (gnu build vm)
+                           (srfi srfi-19)
+                           (guix build store-copy))
+
+              (let* ((inputs '#$(append (list tar)
+                                        (if register-closures?
+                                            (list guix)
+                                            '())))
+                     ;; This initializer requires elevated privileges that are
+                     ;; not normally available in the build environment (e.g.,
+                     ;; it needs to create device nodes).  In order to obtain
+                     ;; such privileges, we run it as root in a VM.
+                     (initialize (root-partition-initializer
+                                  #:closures '(#$graph)
+                                  #:register-closures? #$register-closures?
+                                  #:system-directory #$os-drv
+                                  ;; De-duplication would fail due to
+                                  ;; cross-device link errors, so don't do it.
+                                  #:deduplicate? #f))
+                     ;; Even as root in a VM, the initializer would fail due to
+                     ;; lack of privileges if we use a root-directory that is on
+                     ;; a file system that is shared with the host (e.g., /tmp).
+                     (root-directory "/guixsd-system-root"))
+                (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+                (mkdir root-directory)
+                (initialize root-directory)
+                (build-docker-image
+                 (string-append "/xchg/" #$name) ;; The output file.
+                 (cons* root-directory
+                        (call-with-input-file (string-append "/xchg/" #$graph)
+                          read-reference-graph))
+                 #$os-drv
+                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+                 #:creation-time (make-time time-utc 0 1)
+                 #:transformations `((,root-directory -> ""))))))))
     (expression->derivation-in-linux-vm
      name
      ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
@@ -571,7 +580,6 @@ to USB sticks meant to be read-only."
               (file-systems (cons (file-system
                                     (mount-point "/")
                                     (device root-uuid)
-                                    (title 'uuid)
                                     (type file-system-type))
                                   file-systems-to-keep)))))
 
@@ -636,7 +644,6 @@ of the GNU system as described by OS."
               (file-systems (cons (file-system
                                     (mount-point "/")
                                     (device root-uuid)
-                                    (title 'uuid)
                                     (type file-system-type))
                                   file-systems-to-keep)))))
     (mlet* %store-monad
@@ -693,13 +700,12 @@ environment with the store shared with the host.  MAPPINGS is a list of
                     (source (file-system-device fs)))
                 (or (string=? target (%store-prefix))
                     (string=? target "/")
-                    (and (eq? 'device (file-system-title fs))
+                    (and (string? source)
                          (string-prefix? "/dev/" source))
 
                     ;; Labels and UUIDs are necessarily invalid in the VM.
                     (and (file-system-mount? fs)
-                         (or (eq? 'label (file-system-title fs))
-                             (eq? 'uuid (file-system-title fs))
+                         (or (file-system-label? source)
                              (uuid? source))))))
             (operating-system-file-systems os)))
 
@@ -752,6 +758,10 @@ with the host.
 When FULL-BOOT? is true, return an image that does a complete boot sequence,
 bootloaded included; thus, make a disk image that contains everything the
 bootloader refers to: OS kernel, initrd, bootloader data, etc."
+  (define root-uuid
+    ;; Use a fixed UUID to improve determinism.
+    (operating-system-uuid os 'dce))
+
   (mlet* %store-monad ((os-drv   (operating-system-derivation os))
                        (bootcfg  (operating-system-bootcfg os)))
     ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
@@ -763,6 +773,7 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc."
                 #:bootloader (bootloader-configuration-bootloader
                               (operating-system-bootloader os))
                 #:disk-image-size disk-image-size
+                #:file-system-uuid root-uuid
                 #:inputs (if full-boot?
                              `(("bootcfg" ,bootcfg))
                              '())