Merge branch 'master' into staging

6 files changed, 132 insertions, 63 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 68ecd6bc71..0e77677de1 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -148,11 +148,15 @@ properties.  Return #t on success."
                           `("-G" ,(string-join supplementary-groups ","))
                           '())
                     ,@(if comment `("-c" ,comment) '())
-                    ,@(if (and home create-home?)
-                          (if (file-exists? home)
-                              `("-d" ,home)     ; avoid warning from 'useradd'
-                              `("-d" ,home "--create-home"))
+                    ,@(if home `("-d" ,home) '())
+
+                    ;; Home directories of non-system accounts are created by
+                    ;; 'activate-user-home'.
+                    ,@(if (and home create-home? system?
+                               (not (file-exists? home)))
+                          '("--create-home")
                           '())
+
                     ,@(if shell `("-s" ,shell) '())
                     ,@(if password `("-p" ,password) '())
                     ,@(if system? '("--system") '())
@@ -229,10 +233,7 @@ numeric gid or #f."
                      #:supplementary-groups supplementary-groups
                      #:comment comment
                      #:home home
-
-                     ;; Home directories of non-system accounts are created by
-                     ;; 'activate-user-home'.
-                     #:create-home? (and create-home? system?)
+                     #:create-home? create-home?
 
                      #:shell shell
                      #:password password)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 5a5e703872..c9ebe124fe 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -18,7 +18,6 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build install)
-  #:use-module (guix store database)
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
   #:use-module (srfi srfi-26)
@@ -27,6 +26,7 @@
             evaluate-populate-directive
             populate-root-file-system
             register-closure
+            install-database-and-gc-roots
             populate-single-profile-directory))
 
 ;;; Commentary:
@@ -141,41 +141,53 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
                 (try))
               (apply throw args)))))))
 
-(define* (register-closure prefix closure
-                           #:key
-                           (deduplicate? #t) (reset-timestamps? #t)
-                           (schema (sql-schema)))
-  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
-target store and CLOSURE is the name of a file containing a reference graph as
-produced by #:references-graphs..  As a side effect, if RESET-TIMESTAMPS? is
-true, reset timestamps on store files and, if DEDUPLICATE? is true,
-deduplicates files common to CLOSURE and the rest of PREFIX."
-  (let ((items (call-with-input-file closure read-reference-graph)))
-    (register-items items
-                    #:prefix prefix
-                    #:deduplicate? deduplicate?
-                    #:reset-timestamps? reset-timestamps?
-                    #:registration-time %epoch
-                    #:schema schema)))
+(define %root-profile
+  "/var/guix/profiles/per-user/root")
+
+(define* (install-database-and-gc-roots root database profile
+                                        #:key (profile-name "guix-profile"))
+  "Install DATABASE, the store database, under directory ROOT.  Create
+PROFILE-NAME and have it link to PROFILE, a store item."
+  (define (scope file)
+    (string-append root "/" file))
+
+  (define (mkdir-p* dir)
+    (mkdir-p (scope dir)))
+
+  (define (symlink* old new)
+    (symlink old (scope new)))
+
+  (install-file database (scope "/var/guix/db/"))
+  (chmod (scope "/var/guix/db/db.sqlite") #o644)
+  (mkdir-p* "/var/guix/profiles")
+  (mkdir-p* "/var/guix/gcroots")
+  (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")
+
+  ;; Make root's profile, which makes it a GC root.
+  (mkdir-p* %root-profile)
+  (symlink* profile
+            (string-append %root-profile "/" profile-name "-1-link"))
+  (symlink* (string-append profile-name "-1-link")
+            (string-append %root-profile "/" profile-name)))
 
 (define* (populate-single-profile-directory directory
                                             #:key profile closure
-                                            deduplicate?
-                                            register? schema)
+                                            (profile-name "guix-profile")
+                                            database)
   "Populate DIRECTORY with a store containing PROFILE, whose closure is given
 in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
 is initialized to contain a single profile under /root pointing to PROFILE.
-When REGISTER? is true, initialize DIRECTORY/var/guix/db to reflect the
-contents of the store; DEDUPLICATE? determines whether to deduplicate files in
-the store.
+
+When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
+DIRECTORY/var/guix/gcroots and friends.
+
+PROFILE-NAME is the name of the profile being created under
+/var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
 
 This is used to create the self-contained tarballs with 'guix pack'."
   (define (scope file)
     (string-append directory "/" file))
 
-  (define %root-profile
-    "/var/guix/profiles/per-user/root")
-
   (define (mkdir-p* dir)
     (mkdir-p (scope dir)))
 
@@ -185,25 +197,20 @@ This is used to create the self-contained tarballs with 'guix pack'."
   ;; Populate the store.
   (populate-store (list closure) directory)
 
-  (when register?
-    (register-closure (canonicalize-path directory) closure
-                      #:deduplicate? deduplicate?
-                      #:schema schema)
-
-    (mkdir-p* "/var/guix/profiles")
-    (mkdir-p* "/var/guix/gcroots")
-    (symlink* "/var/guix/profiles"
-              "/var/guix/gcroots/profiles"))
-
-  ;; Make root's profile, which makes it a GC root.
-  (mkdir-p* %root-profile)
-  (symlink* profile
-            (string-append %root-profile "/guix-profile-1-link"))
-  (symlink* (string-append %root-profile "/guix-profile-1-link")
-            (string-append %root-profile "/guix-profile"))
-
-  (mkdir-p* "/root")
-  (symlink* (string-append %root-profile "/guix-profile")
-            "/root/.guix-profile"))
+  (when database
+    (install-database-and-gc-roots directory database profile
+                                   #:profile-name profile-name))
+
+  (match profile-name
+    ("guix-profile"
+     (mkdir-p* "/root")
+     (symlink* (string-append %root-profile "/guix-profile")
+               "/root/.guix-profile"))
+    ("current-guix"
+     (mkdir-p* "/root/.config/guix")
+     (symlink* (string-append %root-profile "/current-guix")
+               "/root/.config/guix/current"))
+    (_
+     #t)))
 
 ;;; install.scm ends here
diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm
index c65b5aacfa..3aaa06d3a0 100644
--- a/gnu/build/linux-initrd.scm
+++ b/gnu/build/linux-initrd.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -72,11 +72,23 @@ COMPRESS? is true, compress it using GZIP.  On success, return OUTPUT."
                                #:file->header cpio:file->cpio-header*)))
 
   (or (not compress?)
-      ;; Use '--no-name' so that gzip records neither a file name nor a time
-      ;; stamp in its output.
-      (and (zero? (system* gzip "--best" "--no-name" output))
-           (rename-file (string-append output ".gz")
-                        output))
+
+      ;; Gzip insists on adding a '.gz' suffix and does nothing if the input
+      ;; file already has that suffix.  Shuffle files around to placate it.
+      (let* ((gz-suffix? (string-suffix? ".gz" output))
+             (sans-gz    (if gz-suffix?
+                             (string-drop-right output 3)
+                             output)))
+        (when gz-suffix?
+          (rename-file output sans-gz))
+        ;; Use '--no-name' so that gzip records neither a file name nor a time
+        ;; stamp in its output.
+        (and (zero? (system* gzip "--best" "--no-name" sans-gz))
+             (begin
+               (unless gz-suffix?
+                 (rename-file (string-append output ".gz") output))
+               output)))
+
       output))
 
 (define (cache-compiled-file-name file)
@@ -139,6 +151,12 @@ REFERENCES-GRAPHS."
 
     (write-cpio-archive output "." #:gzip gzip))
 
+  ;; Make sure directories are writable so we can delete files.
+  (for-each make-file-writable
+            (find-files "contents"
+                        (lambda (file stat)
+                          (eq? 'directory (stat:type stat)))
+                        #:directories? #t))
   (delete-file-recursively "contents"))
 
 ;;; linux-initrd.scm ends here
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index ae141b6f54..2d81175041 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -136,7 +136,7 @@ and normalizing it."
 (define (find-module-file directory module)
   "Lookup module NAME under DIRECTORY, and return its absolute file name.
 NAME can be a file name with or without '.ko', or it can be a module name.
-Return #f if it could not be found.
+Raise an error if it could not be found.
 
 Module names can differ from file names in interesting ways; for instance,
 module names usually (always?) use underscores as the inter-word separator,
@@ -162,7 +162,7 @@ whereas file names often, but not always, use hyphens.  Examples:
     ((file)
      file)
     (()
-     #f)
+     (error "kernel module not found" module directory))
     ((_ ...)
      (error "several modules by that name" module directory))))
 
diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index bb018fc9c1..f94eab5cc0 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,6 +28,7 @@
             marionette-eval
             wait-for-file
             wait-for-tcp-port
+            wait-for-unix-socket
             marionette-control
             marionette-screen-text
             wait-for-screen-text
@@ -214,6 +216,29 @@ MARIONETTE.  Raise an error on failure."
     ('failure
      (error "nobody's listening on port" port))))
 
+(define* (wait-for-unix-socket file-name marionette
+                                #:key (timeout 20))
+  "Wait for up to TIMEOUT seconds for FILE-NAME, a Unix domain socket, to
+accept connections in MARIONETTE.  Raise an error on failure."
+  (match (marionette-eval
+          `(begin
+             (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
+               (let loop ((i 0))
+                 (catch 'system-error
+                   (lambda ()
+                     (connect sock AF_UNIX ,file-name)
+                     'success)
+                   (lambda args
+                     (if (< i ,timeout)
+                         (begin
+                           (sleep 1)
+                           (loop (+ 1 i)))
+                         'failure))))))
+          marionette)
+    ('success #t)
+    ('failure
+     (error "nobody's listening on unix domain socket" file-name))))
+
 (define (marionette-control command marionette)
   "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
 \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
@@ -222,7 +247,8 @@ pcsys_monitor\")."
     (($ <marionette> _ _ monitor)
      (display command monitor)
      (newline monitor)
-     (wait-for-monitor-prompt monitor))))
+     ;; The "quit" command terminates QEMU immediately, with no output.
+     (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))
 
 (define* (marionette-screen-text marionette
                                  #:key
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 5579886264..746808515f 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -25,7 +25,7 @@
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
   #:use-module (guix build syscalls)
-  #:use-module ((guix store database) #:select (reset-timestamps))
+  #:use-module (guix store database)
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
   #:use-module (gnu system uuid)
@@ -191,6 +191,23 @@ the #:references-graphs parameter of 'derivation'."
           (mkdir output)
           (copy-recursively "xchg" output)))))
 
+(define* (register-closure prefix closure
+                           #:key
+                           (deduplicate? #t) (reset-timestamps? #t)
+                           (schema (sql-schema)))
+  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
+target store and CLOSURE is the name of a file containing a reference graph as
+produced by #:references-graphs..  As a side effect, if RESET-TIMESTAMPS? is
+true, reset timestamps on store files and, if DEDUPLICATE? is true,
+deduplicates files common to CLOSURE and the rest of PREFIX."
+  (let ((items (call-with-input-file closure read-reference-graph)))
+    (register-items items
+                    #:prefix prefix
+                    #:deduplicate? deduplicate?
+                    #:reset-timestamps? reset-timestamps?
+                    #:registration-time %epoch
+                    #:schema schema)))
+
 
 ;;;
 ;;; Partitions.