04/08: gnu: Add Linux container module.

[David Thompson]

davexunit pushed a commit to branch wip-container
in repository guix.

commit 5de974b128052217c1b1d2628ec1363c9ab6a748
Author: David Thompson <address@hidden>
Date:   Tue Jun 2 08:48:16 2015 -0400

    gnu: Add Linux container module.
    
    * gnu/build/linux-container.scm: New file.
    * gnu-system.am (GNU_SYSTEM_MODULES): Add it.
    * .dir-locals.el: Add Scheme indent rules for 'call-with-clone', 
'with-clone',
      and 'call-with-container'.
---
 .dir-locals.el                |    4 +
 gnu-system.am                 |    1 +
 gnu/build/linux-container.scm |  139 +++++++++++++++++++++++++++++++++++++++++
 3 files changed, 144 insertions(+), 0 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index cbcb120..31397f7 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -59,6 +59,10 @@
    (eval . (put 'run-with-state 'scheme-indent-function 1))
    (eval . (put 'wrap-program 'scheme-indent-function 1))
 
+   (eval . (put 'call-with-clone 'scheme-indent-function 1))
+   (eval . (put 'with-clone 'scheme-indent-function 1))
+   (eval . (put 'call-with-container 'scheme-indent-function 2))
+
    ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols.
    ;; This notably allows '(' in Paredit to not insert a space when the
    ;; preceding symbol is one of these.
diff --git a/gnu-system.am b/gnu-system.am
index 3073fef..3714bbd 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -354,6 +354,7 @@ GNU_SYSTEM_MODULES =                                \
   gnu/build/file-systems.scm                   \
   gnu/build/install.scm                                \
   gnu/build/linux-boot.scm                     \
+  gnu/build/linux-container.scm                        \
   gnu/build/linux-initrd.scm                   \
   gnu/build/linux-modules.scm                  \
   gnu/build/vm.scm
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
new file mode 100644
index 0000000..0b16b4c
--- /dev/null
+++ b/gnu/build/linux-container.scm
@@ -0,0 +1,139 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <address@hidden>
+;;;
+;;; 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 linux-container)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (guix build utils)
+  #:use-module (guix build syscalls)
+  #:export (call-with-container))
+
+(define (call-with-clone namespaces thunk)
+  "Run THUNK in a separate process with a set of NAMESPACES
+disassociated from the current process."
+  (match (clone (apply logior namespaces))
+    (0 (thunk))
+    (pid *unspecified*)))
+
+(define-syntax-rule (with-clone namespaces body ...)
+  "Evaluate BODY in a new process with the specified new NAMESPACES."
+  (call-with-clone namespaces (lambda () body ...)))
+
+(define* (mount* source target type #:optional (flags 0) options
+                 #:key (update-mtab? #f))
+  "Like 'mount', but create the TARGET directory if it doesn't exist."
+  (pk 'target target)
+  (mkdir-p target)
+  (mount source target type flags options #:update-mtab? update-mtab?))
+
+(define (call-with-container root-dir shared-dirs thunk)
+  "Run THUNK in a new container process with the root file system located at
+ROOT-DIR.  SHARED-DIRS is a list of (HOST-DIR CONTAINER-DIR) tuples that will
+be bind mounted within the container."
+  (define (scope dir)
+    (string-append root-dir dir))
+
+  ;; The container setup procedure closely resembles that of the Docker
+  ;; specification:
+  ;; https://raw.githubusercontent.com/docker/libcontainer/master/SPEC.md
+  (let* ((new-proc   (scope "/proc"))
+         (new-dev    (scope "/dev"))
+         (new-sys    (scope "/sys"))
+         (dev-shm    (string-append new-dev "/shm"))
+         (dev-mqueue (string-append new-dev "/mqueue"))
+         (dev-pts    (string-append new-dev "/pts"))
+         (uid        (getuid))
+         (gid        (getgid)))
+
+    ;; FIXME: User namespaces do not work yet
+    (with-clone (list CLONE_NEWNS
+                      CLONE_NEWUTS
+                      CLONE_NEWIPC
+                      ;; CLONE_NEWUSER
+                      CLONE_NEWPID
+                      CLONE_NEWNET)
+
+      ;; Map user and group.
+      ;; (call-with-output-file "/proc/self/setgroups"
+      ;;   (lambda (port)
+      ;;     (display "deny" port)))
+      ;; (call-with-output-file "/proc/self/uid_map"
+      ;;   (lambda (port)
+      ;;     (format port "0 ~d 1" uid)))
+      ;; (call-with-output-file "/proc/self/gid_map"
+      ;;   (lambda (port)
+      ;;     (format port "0 ~d 1" gid)))
+
+      ;; Create essential mount points.
+      (mount* "none" new-proc "proc"
+              (logior MS_NOEXEC MS_NOSUID MS_NODEV))
+      (mount* "none" new-dev "tmpfs"
+              (logior MS_NOEXEC MS_STRICTATIME)
+              "mode=755")
+      (mount* "none" new-sys "sysfs"
+              (logior MS_NOEXEC MS_NOSUID MS_NODEV MS_RDONLY))
+      (mount* "none" dev-shm "tmpfs"
+              (logior MS_NOEXEC MS_NOSUID MS_NODEV)
+              "mode=1777,size=65536k")
+      (mount* "none" dev-mqueue "mqueue"
+              (logior MS_NOEXEC MS_NOSUID MS_NODEV))
+      (mount* "none" dev-pts "devpts"
+              (logior MS_NOEXEC MS_NOSUID)
+              "newinstance,ptmxmode=0666,mode=620")
+
+      ;; Create essential device nodes via bind mounting them from the host,
+      ;; because a container within a user namespace cannot create device
+      ;; nodes.
+      (for-each (lambda (device)
+                  (call-with-output-file (scope device)
+                    (const #t))
+                  (mount device (scope device)
+                         "none" MS_BIND))
+                '("/dev/null"
+                  "/dev/zero"
+                  "/dev/full"
+                  "/dev/random"
+                  "/dev/urandom"
+                  "/dev/tty"
+                  ;; TODO: "/dev/fuse"
+                  ))
+
+      ;; For psuedo-ttys within the container.  Needs to be a symlink to the
+      ;; host's /dev/ptmx.
+      (symlink "/dev/ptmx" (scope "/dev/ptmx"))
+
+      ;; Setup IO.
+      (symlink "/proc/self/fd"   (scope "/dev/fd"))
+      (symlink "/proc/self/fd/0" (scope "/dev/stdin"))
+      (symlink "/proc/self/fd/1" (scope "/dev/stdout"))
+      (symlink "/proc/self/fd/2" (scope "/dev/stderr"))
+
+      ;; Bind-mount shared directories.
+      ;; TODO: Use <file-system-mapping>
+      (for-each (match-lambda
+                  ((host-dir container-dir)
+                   (mount* host-dir (scope container-dir)
+                           "none" MS_BIND)))
+                shared-dirs)
+
+      ;; Enter the container's root file system.
+      (chroot root-dir)
+      (chdir "/")
+
+      ;; Go little container, go!
+      (thunk))))