davexunit pushed a commit to branch wip-container
in repository guix.
commit 6ac8d428bdd76faf65ddf4a99ce03a7bf398a40f
Author: David Thompson <da...@gnu.org>
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 | 142 +++++++++++++++++++++++++++++++++++++++++
3 files changed, 147 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 a420d71..3bb8982 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -356,6 +356,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..12f0acc
--- /dev/null
+++ b/gnu/build/linux-container.scm
@@ -0,0 +1,142 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <da...@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 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 pid)))
+
+(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."
+ (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!
+ (dynamic-wind
+ (const #t)
+ thunk
+ (lambda ()
+ (primitive-exit 1))))))
