Merge branch 'master' into core-updates

4 files changed, 188 insertions, 59 deletions

diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 67da6fc3bf..4f88c513c0 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -160,6 +161,13 @@ COMMAND or an interactive shell in that environment.\n"))
   (display (G_ "
   -N, --network          allow containers to access the network"))
   (display (G_ "
+  -P, --link-profile     link environment profile to ~/.guix-profile within
+                         an isolated container"))
+  (display (G_ "
+  -u, --user=USER        instead of copying the name and home of the current
+                         user into an isolated container, use the name USER
+                         with home directory /home/USER"))
+  (display (G_ "
       --share=SPEC       for containers, share writable host file system
                          according to SPEC"))
   (display (G_ "
@@ -243,6 +251,13 @@ COMMAND or an interactive shell in that environment.\n"))
          (option '(#\N "network") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'network? #t result)))
+         (option '(#\P "link-profile") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'link-profile? #t result)))
+         (option '(#\u "user") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'user arg
+                               (alist-delete 'user result eq?))))
          (option '("share") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'file-system-mapping
@@ -403,41 +418,50 @@ environment variables are cleared before setting the new ones."
     (pid (match (waitpid pid)
            ((_ . status) status)))))
 
-(define* (launch-environment/container #:key command bash user-mappings
-                                       profile paths network?)
+(define* (launch-environment/container #:key command bash user user-mappings
+                                       profile paths link-profile? network?)
   "Run COMMAND within a container that features the software in PROFILE.
 Environment variables are set according to PATHS, a list of native search
 paths.  The global shell is BASH, a file name for a GNU Bash binary in the
 store.  When NETWORK?, access to the host system network is permitted.
 USER-MAPPINGS, a list of file system mappings, contains the user-specified
-host file systems to mount inside the container."
+host file systems to mount inside the container.  If USER is not #f, each
+target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER
+will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
+~/.guix-profile to the environment profile."
   (mlet %store-monad ((reqs (inputs->requisites
                              (list (direct-store-path bash) profile))))
     (return
-     (let* ((cwd (getcwd))
-            (passwd (getpwuid (getuid)))
+     (let* ((cwd      (getcwd))
+            (home     (getenv "HOME"))
+            (passwd   (mock-passwd (getpwuid (getuid))
+                                   user
+                                   bash))
+            (home-dir (passwd:dir passwd))
             ;; Bind-mount all requisite store items, user-specified mappings,
             ;; /bin/sh, the current working directory, and possibly networking
             ;; configuration files within the container.
             (mappings
-             (append user-mappings
-                     ;; Current working directory.
-                     (list (file-system-mapping
-                            (source cwd)
-                            (target cwd)
-                            (writable? #t)))
-                     ;; When in Rome, do as Nix build.cc does: Automagically
-                     ;; map common network configuration files.
-                     (if network?
-                         %network-file-mappings
-                         '())
-                     ;; Mappings for the union closure of all inputs.
-                     (map (lambda (dir)
-                            (file-system-mapping
-                             (source dir)
-                             (target dir)
-                             (writable? #f)))
-                          reqs)))
+             (override-user-mappings
+              user home
+              (append user-mappings
+                      ;; Current working directory.
+                      (list (file-system-mapping
+                             (source cwd)
+                             (target cwd)
+                             (writable? #t)))
+                      ;; When in Rome, do as Nix build.cc does: Automagically
+                      ;; map common network configuration files.
+                      (if network?
+                          %network-file-mappings
+                          '())
+                      ;; Mappings for the union closure of all inputs.
+                      (map (lambda (dir)
+                             (file-system-mapping
+                              (source dir)
+                              (target dir)
+                              (writable? #f)))
+                           reqs))))
             (file-systems (append %container-file-systems
                                   (map file-system-mapping->bind-mount
                                        mappings))))
@@ -458,10 +482,14 @@ host file systems to mount inside the container."
                       ;; The same variables as in Nix's 'build.cc'.
                       '("TMPDIR" "TEMPDIR" "TMP" "TEMP"))
 
-            ;; Create a dummy home directory under the same name as on the
-            ;; host.
-            (mkdir-p (passwd:dir passwd))
-            (setenv "HOME" (passwd:dir passwd))
+            ;; Create a dummy home directory.
+            (mkdir-p home-dir)
+            (setenv "HOME" home-dir)
+
+            ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile;
+            ;; this allows programs expecting that path to continue working as
+            ;; expected within a container.
+            (when link-profile? (link-environment profile home-dir))
 
             ;; Create a dummy /etc/passwd to satisfy applications that demand
             ;; to read it, such as 'git clone' over SSH, a valid use-case when
@@ -481,7 +509,7 @@ host file systems to mount inside the container."
 
             ;; For convenience, start in the user's current working
             ;; directory rather than the root directory.
-            (chdir cwd)
+            (chdir (override-user-dir user home cwd))
 
             (primitive-exit/status
              ;; A container's environment is already purified, so no need to
@@ -491,6 +519,72 @@ host file systems to mount inside the container."
                            (delq 'net %namespaces) ; share host network
                            %namespaces)))))))
 
+(define (mock-passwd passwd user-override shell)
+  "Generate mock information for '/etc/passwd'.  If USER-OVERRIDE is not '#f',
+it is expected to be a string representing the mock username; it will produce
+a user of that name, with a home directory of '/home/USER-OVERRIDE', and no
+GECOS field.  If USER-OVERRIDE is '#f', data will be inherited from PASSWD.
+In either case, the shadow password and UID/GID are cleared, since the user
+runs as root within the container.  SHELL will always be used in place of the
+shell in PASSWD.
+
+The resulting vector is suitable for use with Guile's POSIX user procedures.
+
+See passwd(5) for more information each of the fields."
+  (if user-override
+      (vector
+       user-override
+        "x" "0" "0"  ;; no shadow, user is now root
+        ""           ;; no personal information
+        (user-override-home user-override)
+        shell)
+      (vector
+       (passwd:name passwd)
+        "x" "0" "0"  ;; no shadow, user is now root
+        (passwd:gecos passwd)
+        (passwd:dir passwd)
+        shell)))
+
+(define (user-override-home user)
+  "Return home directory for override user USER."
+  (string-append "/home/" user))
+
+(define (override-user-mappings user home mappings)
+  "If a username USER is provided, rewrite each HOME prefix in file system
+mappings MAPPINGS to a home directory determined by 'override-user-dir';
+otherwise, return MAPPINGS."
+  (if (not user)
+      mappings
+      (map (lambda (mapping)
+             (let ((target (file-system-mapping-target mapping)))
+               (if (string-prefix? home target)
+                   (file-system-mapping
+                    (source    (file-system-mapping-source mapping))
+                    (target    (override-user-dir user home target))
+                    (writable? (file-system-mapping-writable? mapping)))
+                   mapping)))
+           mappings)))
+
+(define (override-user-dir user home dir)
+  "If username USER is provided, overwrite string prefix HOME in DIR with a
+directory determined by 'user-override-home'; otherwise, return DIR."
+  (if (and user (string-prefix? home dir))
+      (string-append (user-override-home user)
+                     (substring dir (string-length home)))
+      dir))
+
+(define (link-environment profile home-dir)
+  "Create a symbolic link from HOME-DIR/.guix-profile to PROFILE."
+  (let ((profile-dir (string-append home-dir "/.guix-profile")))
+    (catch 'system-error
+      (lambda ()
+        (symlink profile profile-dir))
+      (lambda args
+        (if (= EEXIST (system-error-errno args))
+            (leave (G_ "cannot link profile: '~a' already exists within container~%")
+                   profile-dir)
+            (apply throw args))))))
+
 (define (environment-bash container? bootstrap? system)
   "Return a monadic value in the store monad for the version of GNU Bash
 needed in the environment for SYSTEM, if any.  If CONTAINER? is #f, return #f.
@@ -564,7 +658,9 @@ message if any test fails."
     (let* ((opts       (parse-args args))
            (pure?      (assoc-ref opts 'pure))
            (container? (assoc-ref opts 'container?))
+           (link-prof? (assoc-ref opts 'link-profile?))
            (network?   (assoc-ref opts 'network?))
+           (user       (assoc-ref opts 'user))
            (bootstrap? (assoc-ref opts 'bootstrap?))
            (system     (assoc-ref opts 'system))
            (command    (or (assoc-ref opts 'exec)
@@ -597,6 +693,11 @@ message if any test fails."
 
       (when container? (assert-container-features))
 
+      (when (and (not container?) link-prof?)
+        (leave (G_ "'--link-profile' cannot be used without '--container'~%")))
+      (when (and (not container?) user)
+        (leave (G_ "'--user' cannot be used without '--container'~%")))
+
       (with-store store
         (set-build-options-from-command-line store opts)
 
@@ -643,9 +744,11 @@ message if any test fails."
                                             "/bin/sh"))))
                     (launch-environment/container #:command command
                                                   #:bash bash-binary
+                                                  #:user user
                                                   #:user-mappings mappings
                                                   #:profile profile
                                                   #:paths paths
+                                                  #:link-profile? link-prof?
                                                   #:network? network?)))
                  (else
                   (return
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 617e102d93..d8b80efe8e 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
@@ -247,11 +247,15 @@ specified in MANIFEST, a manifest object."
 description matches at least one of REGEXPS sorted by relevance, and the list
 of relevance scores."
   (let ((matches (fold-packages (lambda (package result)
-                                  (match (package-relevance package regexps)
-                                    ((? zero?)
-                                     result)
-                                    (score
-                                     (cons (list package score) result))))
+                                  (if (package-superseded package)
+                                      result
+                                      (match (package-relevance package
+                                                                regexps)
+                                        ((? zero?)
+                                         result)
+                                        (score
+                                         (cons (list package score)
+                                               result)))))
                                 '())))
     (unzip2 (sort matches
                   (lambda (m1 m2)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 2fd2bf8104..8e1119fb49 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -212,15 +212,7 @@ provide."
            (begin
              (warning (G_ "while fetching ~a: server is somewhat slow~%")
                       (uri->string uri))
-             (warning (G_ "try `--no-substitutes' if the problem persists~%"))
-
-             ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
-             ;; and thus PORT had to be closed and re-opened.  This is not the
-             ;; case afterward.
-             (unless (or (guile-version>? "2.0.9")
-                         (version>? (version) "2.0.9.39"))
-               (when port
-                 (close-connection port))))
+             (warning (G_ "try `--no-substitutes' if the problem persists~%")))
            (begin
              (when (or (not port) (port-closed? port))
                (set! port (guix:open-connection-for-uri
@@ -571,10 +563,8 @@ initial connection on which HTTP requests are sent."
       ;; XXX: Do our own caching to work around inefficiencies when
       ;; communicating over TLS: <http://bugs.gnu.org/22966>.
       (let-values (((buffer get) (open-bytevector-output-port)))
-        ;; On Guile > 2.0.9, inherit the HTTP proxying property from P.
-        (when (module-variable (resolve-interface '(web http))
-                               'http-proxy-port?)
-          (set-http-proxy-port?! buffer (http-proxy-port? p)))
+        ;; Inherit the HTTP proxying property from P.
+        (set-http-proxy-port?! buffer (http-proxy-port? p))
 
         (for-each (cut write-request <> buffer)
                   (at-most 1000 requests))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 999ffb010b..acfccce96d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,9 @@
   #:use-module (gnu build install)
   #:autoload   (gnu build file-systems)
                  (find-partition-by-label find-partition-by-uuid)
+  #:autoload   (gnu build linux-modules)
+                 (device-module-aliases matching-modules)
+  #:use-module (gnu system linux-initrd)
   #:use-module (gnu system)
   #:use-module (gnu bootloader)
   #:use-module (gnu system file-systems)
@@ -624,21 +627,49 @@ any, are available.  Raise an error if they're not."
       ;; Better be safe than sorry.
       (exit 1))))
 
-(define (check-mapped-devices mapped-devices)
+(define (check-mapped-devices os)
   "Check that each of MAPPED-DEVICES is valid according to the 'check'
 procedure of its type."
+  (define boot-mapped-devices
+    (operating-system-boot-mapped-devices os))
+
+  (define (needed-for-boot? md)
+    (memq md boot-mapped-devices))
+
+  (define initrd-modules
+    (operating-system-initrd-modules os))
+
   (for-each (lambda (md)
               (let ((check (mapped-device-kind-check
                             (mapped-device-type md))))
                 ;; We expect CHECK to raise an exception with a detailed
-                ;; '&message' if something goes wrong, but handle the case
-                ;; where it just returns #f.
-                (unless (check md)
-                  (leave (G_ "~a: invalid '~a' mapped device~%")
-                         (location->string
-                          (source-properties->location
-                           (mapped-device-location md)))))))
-            mapped-devices))
+                ;; '&message' if something goes wrong.
+                (check md
+                       #:needed-for-boot? (needed-for-boot? md)
+                       #:initrd-modules initrd-modules)))
+            (operating-system-mapped-devices os)))
+
+(define (check-initrd-modules os)
+  "Check that modules needed by 'needed-for-boot' file systems in OS are
+available in the initrd.  Note that mapped devices are responsible for
+checking this by themselves in their 'check' procedure."
+  (define (file-system-/dev fs)
+    (let ((device (file-system-device fs)))
+      (match (file-system-title fs)
+        ('device device)
+        ('uuid   (find-partition-by-uuid device))
+        ('label  (find-partition-by-label device)))))
+
+  (define file-systems
+    (filter file-system-needed-for-boot?
+            (operating-system-file-systems os)))
+
+  (for-each (lambda (fs)
+              (check-device-initrd-modules (file-system-/dev fs)
+                                           (operating-system-initrd-modules os)
+                                           (source-properties->location
+                                            (file-system-location fs))))
+            file-systems))
 
 
 ;;;
@@ -730,9 +761,10 @@ output when building a system derivation, such as a disk image."
   ;; instantiating a broken configuration.  Assume that we can only check if
   ;; running as root.
   (when (memq action '(init reconfigure))
+    (check-mapped-devices os)
     (when (zero? (getuid))
-      (check-file-system-availability (operating-system-file-systems os)))
-    (check-mapped-devices (operating-system-mapped-devices os)))
+      (check-file-system-availability (operating-system-file-systems os))
+      (check-initrd-modules os)))
 
   (mlet* %store-monad
       ((sys       (system-derivation-for-action os action