Merge branch 'master' into core-updates

3 files changed, 250 insertions, 16 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index d36eeafe47..beee56d437 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -28,7 +28,7 @@
             activate-user-home
             activate-etc
             activate-setuid-programs
-            activate-/bin/sh
+            activate-special-files
             activate-modprobe
             activate-firmware
             activate-ptrace-attach
@@ -80,16 +80,27 @@
   (member file '("." "..")))
 
 (define* (copy-account-skeletons home
-                                 #:optional (directory %skeleton-directory))
-  "Copy the account skeletons from DIRECTORY to HOME."
+                                 #:key
+                                 (directory %skeleton-directory)
+                                 uid gid)
+  "Copy the account skeletons from DIRECTORY to HOME.  When UID is an integer,
+make it the owner of all the files created; likewise for GID."
+  (define (set-owner file)
+    (when (or uid gid)
+      (chown file (or uid -1) (or gid -1))))
+
   (let ((files (scandir directory (negate dot-or-dot-dot?)
                         string<?)))
     (mkdir-p home)
+    (set-owner home)
     (for-each (lambda (file)
                 (let ((target (string-append home "/" file)))
                   (copy-recursively (string-append directory "/" file)
                                     target
                                     #:log (%make-void-port "w"))
+                  (for-each set-owner
+                            (find-files target (const #t)
+                                        #:directories? #t))
                   (make-file-writable target)))
               files)))
 
@@ -272,9 +283,14 @@ they already exist."
       ((name uid group supplementary-groups comment home create-home?
              shell password system?)
        (unless (or (not home) (directory-exists? home))
-         (mkdir-p home)
-         (unless system?
-           (copy-account-skeletons home))))))
+         (let* ((pw  (getpwnam name))
+                (uid (passwd:uid pw))
+                (gid (passwd:gid pw)))
+           (mkdir-p home)
+           (chown home uid gid)
+           (unless system?
+             (copy-account-skeletons home
+                                     #:uid uid #:gid gid)))))))
 
   (for-each ensure-user-home users))
 
@@ -362,10 +378,23 @@ copy SOURCE to TARGET."
 
   (for-each make-setuid-program programs))
 
-(define (activate-/bin/sh shell)
-  "Change /bin/sh to point to SHELL."
-  (symlink shell "/bin/sh.new")
-  (rename-file "/bin/sh.new" "/bin/sh"))
+(define (activate-special-files special-files)
+  "Install the files listed in SPECIAL-FILES.  Each element of SPECIAL-FILES
+is a pair where the first element is the name of the special file and the
+second element is the name it should appear at, such as:
+
+  ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
+   (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
+"
+  (define install-special-file
+    (match-lambda
+      ((target file)
+       (let ((pivot (string-append target ".new")))
+         (mkdir-p (dirname target))
+         (symlink file pivot)
+         (rename-file pivot target)))))
+
+  (for-each install-special-file special-files))
 
 (define (activate-modprobe modprobe)
   "Tell the kernel to use MODPROBE to load modules."
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index b71d6a5f88..95bfd92dde 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,7 +33,8 @@
             %namespaces
             run-container
             call-with-container
-            container-excursion))
+            container-excursion
+            container-excursion*))
 
 (define (user-namespace-supported?)
   "Return #t if user namespaces are supported on this system."
@@ -128,13 +130,19 @@ for the process."
               "/dev/fuse"))
 
   ;; Setup the container's /dev/console by bind mounting the pseudo-terminal
-  ;; associated with standard input.
-  (let ((in      (current-input-port))
-        (console (scope "/dev/console")))
-    (when (isatty? in)
+  ;; associated with standard input when there is one.
+  (let* ((in      (current-input-port))
+         (tty     (catch 'system-error
+                    (lambda ()
+                      ;; This call throws if IN does not correspond to a tty.
+                      ;; This is more reliable than 'isatty?'.
+                      (ttyname in))
+                    (const #f)))
+         (console (scope "/dev/console")))
+    (when tty
       (touch console)
       (chmod console #o600)
-      (bind-mount (ttyname in) console)))
+      (bind-mount tty console)))
 
   ;; Setup standard input/output/error.
   (symlink "/proc/self/fd"   (scope "/dev/fd"))
@@ -229,6 +237,8 @@ host user identifiers to map into the user namespace."
                                                                namespaces)))
                     (lambda args
                       ;; Forward the exception to the parent process.
+                      ;; FIXME: SRFI-35 conditions and non-trivial objects
+                      ;; cannot be 'read' so they shouldn't be written as is.
                       (write args child)
                       (primitive-exit 3))))
                 ;; TODO: Manage capabilities.
@@ -318,3 +328,21 @@ return the exit status."
      (match (waitpid pid)
        ((_ . status)
         (status:exit-val status))))))
+
+(define (container-excursion* pid thunk)
+  "Like 'container-excursion', but return the return value of THUNK."
+  (match (pipe)
+    ((in . out)
+     (match (container-excursion pid
+              (lambda ()
+                (close-port in)
+                (write (thunk) out)))
+       (0
+        (close-port out)
+        (let ((result (read in)))
+          (close-port in)
+          result))
+       (_                                         ;maybe PID died already
+        (close-port out)
+        (close-port in)
+        #f)))))
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
new file mode 100644
index 0000000000..8fc74bc482
--- /dev/null
+++ b/gnu/build/shepherd.scm
@@ -0,0 +1,177 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build shepherd)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu build linux-container)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:export (make-forkexec-constructor/container))
+
+;;; Commentary:
+;;;
+;;; This module provides extensions to the GNU Shepherd.  In particular, it
+;;; provides a helper to start services in a container.
+;;;
+;;; Code:
+
+(define (clean-up file)
+  (when file
+    (catch 'system-error
+      (lambda ()
+        (delete-file file))
+      (lambda args
+        (unless (= ENOENT (system-error-errno args))
+          (apply throw args))))))
+
+(define-syntax-rule (catch-system-error exp)
+  (catch 'system-error
+    (lambda ()
+      exp)
+    (const #f)))
+
+(define (default-namespaces args)
+  ;; Most daemons are here to talk to the network, and most of them expect to
+  ;; run under a non-zero UID.
+  (fold delq %namespaces '(net user)))
+
+(define* (default-mounts #:key (namespaces (default-namespaces '())))
+  (define (tmpfs directory)
+    (file-system
+      (device "none")
+      (title 'device)
+      (mount-point directory)
+      (type "tmpfs")
+      (check? #f)))
+
+  (define passwd
+    ;; This is for processes in the default user namespace but living in a
+    ;; different mount namespace, so that they can lookup users.
+    (file-system-mapping
+     (source "/etc/passwd") (target source)))
+
+  (define nscd-socket
+    (file-system-mapping
+     (source "/var/run/nscd") (target source)
+     (writable? #t)))
+
+  (append (cons (tmpfs "/tmp") %container-file-systems)
+          (let ((mappings `(,@(if (memq 'net namespaces)
+                                  '()
+                                  (cons nscd-socket
+                                        %network-file-mappings))
+                            ,@(if (and (memq 'mnt namespaces)
+                                       (not (memq 'user namespaces)))
+                                  (list passwd)
+                                  '())
+                            ,%store-mapping)))    ;XXX: coarse-grain
+            (map file-system-mapping->bind-mount
+                 (filter (lambda (mapping)
+                           (file-exists? (file-system-mapping-source mapping)))
+                         mappings)))))
+
+;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
+(module-autoload! (current-module)
+                  '(shepherd service) '(read-pid-file exec-command))
+
+(define* (read-pid-file/container pid pid-file #:key (max-delay 5))
+  "Read PID-FILE in the container namespaces of PID, which exists in a
+separate mount and PID name space.  Return the \"outer\" PID. "
+  (match (container-excursion* pid
+           (lambda ()
+             (read-pid-file pid-file
+                            #:max-delay max-delay)))
+    (#f
+     (catch-system-error (kill pid SIGTERM))
+     #f)
+    ((? integer? container-pid)
+     ;; XXX: When COMMAND is started in a separate PID namespace, its
+     ;; PID is always 1, but that's not what Shepherd needs to know.
+     pid)))
+
+(define* (make-forkexec-constructor/container command
+                                              #:key
+                                              (namespaces
+                                               (default-namespaces args))
+                                              (mappings '())
+                                              (user #f)
+                                              (group #f)
+                                              (log-file #f)
+                                              pid-file
+                                              (pid-file-timeout 5)
+                                              (directory "/")
+                                              (environment-variables
+                                               (environ))
+                                              #:rest args)
+  "This is a variant of 'make-forkexec-constructor' that starts COMMAND in
+NAMESPACES, a list of Linux namespaces such as '(mnt ipc).  MAPPINGS is the
+list of <file-system-mapping> to make in the case of a separate mount
+namespace, in addition to essential bind-mounts such /proc."
+  (define container-directory
+    (match command
+      ((program _  ...)
+       (string-append "/var/run/containers/" (basename program)))))
+
+  (define auto-mappings
+    `(,@(if log-file
+            (list (file-system-mapping
+                   (source log-file)
+                   (target source)
+                   (writable? #t)))
+            '())))
+
+  (define mounts
+    (append (map file-system-mapping->bind-mount
+                 (append auto-mappings mappings))
+            (default-mounts #:namespaces namespaces)))
+
+  (lambda args
+    (mkdir-p container-directory)
+
+    (when log-file
+      ;; Create LOG-FILE so we can map it in the container.
+      (unless (file-exists? log-file)
+        (call-with-output-file log-file (const #t))))
+
+    (let ((pid (run-container container-directory
+                              mounts namespaces 1
+                              (lambda ()
+                                (mkdir-p "/var/run")
+                                (clean-up pid-file)
+                                (clean-up log-file)
+
+                                (exec-command command
+                                              #:user user
+                                              #:group group
+                                              #:log-file log-file
+                                              #:directory directory
+                                              #:environment-variables
+                                              environment-variables)))))
+      (if pid-file
+          (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
+              (read-pid-file/container pid pid-file
+                                       #:max-delay pid-file-timeout)
+              (read-pid-file pid-file #:max-delay pid-file-timeout))
+          pid))))
+
+;; Local Variables:
+;; eval: (put 'container-excursion* 'scheme-indent-function 1)
+;; End:
+
+;;; shepherd.scm ends here