03/03: gnu: Add Linux container module.

[David Thompson]

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

commit ac557b430e3f186f1e900f4762971b65275bb21d
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 |  146 +++++++++++++++++++++++++++++++++++++++++
 3 files changed, 151 insertions(+), 0 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 7ac7e13..670d14d 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 2cd4c62..8078b62 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..0305e95
--- /dev/null
+++ b/gnu/build/linux-container.scm
@@ -0,0 +1,146 @@
+;;; 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 ...)))
+
+;; TODO: Deduplicate
+(define (device-number major minor)
+  "Return the device number for the device with MAJOR and MINOR, for use as
+the last argument of `mknod'."
+  (+ (* major 256) minor))
+
+(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 (in-container dir)
+    (string-append root-dir dir))
+
+  (let* ((new-proc   (in-container "/proc"))
+         (new-dev    (in-container "/dev"))
+         (new-sys    (in-container "/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 as specified by Docker:
+      ;; https://raw.githubusercontent.com/docker/libcontainer/master/SPEC.md
+      (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.
+      (for-each (match-lambda
+                  (((= in-container file) major minor)
+                   (mknod file 'char-special #o666
+                          (device-number major minor))
+                   (chmod file #o666)))
+                '(("/dev/null" 1 3)
+                  ("/dev/zero" 1 5)
+                  ("/dev/full" 1 7)
+                  ("/dev/random" 1 8)
+                  ("/dev/urandom" 1 9)))
+
+      (mknod (in-container "/dev/tty") 'char-special #o666
+             (device-number 5 0))
+      (chmod (in-container "/dev/tty") #o666)
+
+      ;; For psuedo-ttys within the container.  Needs to be a symlink to the
+      ;; host's /dev/ptmx.
+      (symlink "/dev/ptmx" (in-container "/dev/ptmx"))
+
+      ;; FUSE
+      (mknod (in-container "/dev/fuse") 'char-special #o666
+             (device-number 10 229))
+      (chmod (in-container "/dev/fuse") #o666)
+
+      ;; Setup IO.
+      (symlink "/proc/1/fd"   (in-container "/dev/fd"))
+      (symlink "/proc/1/fd/0" (in-container "/dev/stdin"))
+      (symlink "/proc/1/fd/1" (in-container "/dev/stdout"))
+      (symlink "/proc/1/fd/2" (in-container "/dev/stderr"))
+
+      ;; Bind-mount shared directories.
+      (for-each (match-lambda
+                  ((host-dir container-dir)
+                   (mount* host-dir (in-container container-dir)
+                           "none" MS_BIND)))
+                shared-dirs)
+
+      ;; Enter the container's root file system.
+      (chroot root-dir)
+      (chdir "/")
+
+      ;; Go little container, go!
+      (thunk))))