Add (gnu build shepherd).

* gnu/build/shepherd.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

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

gnu/local.mk

@@ -451,6 +451,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/build/linux-initrd.scm			\
   %D%/build/linux-modules.scm			\
   %D%/build/marionette.scm			\
+  %D%/build/shepherd.scm			\
   %D%/build/svg.scm				\
   %D%/build/vm.scm				\
 						\