diff options
| -rw-r--r-- | gnu-system.am | 1 | ||||
| -rw-r--r-- | gnu/system.scm | 30 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 119 |
3 files changed, 140 insertions, 10 deletions
diff --git a/gnu-system.am b/gnu-system.am index cd9561e8b4..d3c63cad33 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -360,6 +360,7 @@ GNU_SYSTEM_MODULES = \ gnu/system/grub.scm \ gnu/system/install.scm \ gnu/system/linux.scm \ + gnu/system/linux-container.scm \ gnu/system/linux-initrd.scm \ gnu/system/locale.scm \ gnu/system/nss.scm \ diff --git a/gnu/system.scm b/gnu/system.scm index ea6e9c13ea..cee5f37bcb 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -83,6 +83,11 @@ operating-system-derivation operating-system-profile operating-system-grub.cfg + operating-system-etc-directory + operating-system-locale-directory + operating-system-boot-script + + file-union local-host-aliases %setuid-programs @@ -689,7 +694,7 @@ variable is not set---hence the need for this wrapper." (apply execl #$modprobe (cons #$modprobe (cdr (command-line)))))))) -(define (operating-system-activation-script os) +(define* (operating-system-activation-script os #:key container?) "Return the activation script for OS---i.e., the code that \"activates\" the stateful part of OS, including user accounts and groups, special directories, etc." @@ -763,12 +768,15 @@ etc." ;; Tell the kernel to use our 'modprobe' command. (activate-modprobe #$modprobe) - ;; Tell the kernel where firmware is. - (activate-firmware - (string-append #$firmware "/lib/firmware")) - - ;; Let users debug their own processes! - (activate-ptrace-attach) + ;; Tell the kernel where firmware is, unless we are + ;; activating a container. + #$@(if container? + #~() + ;; Tell the kernel where firmware is. + #~((activate-firmware + (string-append #$firmware "/lib/firmware")) + ;; Let users debug their own processes! + (activate-ptrace-attach))) ;; Run the services' activation snippets. ;; TODO: Use 'load-compiled'. @@ -777,11 +785,13 @@ etc." ;; Set up /run/current-system. (activate-current-system))))) -(define (operating-system-boot-script os) +(define* (operating-system-boot-script os #:key container?) "Return the boot script for OS---i.e., the code started by the initrd once -we're running in the final root." +we're running in the final root. When CONTAINER? is true, skip all +hardware-related operations as necessary when booting a Linux container." (mlet* %store-monad ((services (operating-system-services os)) - (activate (operating-system-activation-script os)) + (activate (operating-system-activation-script + os #:container? container?)) (dmd-conf (dmd-configuration-file services))) (gexp->file "boot" #~(begin diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm new file mode 100644 index 0000000000..fdf7460872 --- /dev/null +++ b/gnu/system/linux-container.scm @@ -0,0 +1,119 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@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 system linux-container) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (guix config) + #:use-module (guix store) + #:use-module (guix gexp) + #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (gnu build linux-container) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:export (mapping->file-system + system-container + containerized-operating-system + container-script)) + +(define (mapping->file-system mapping) + "Return a file system that realizes MAPPING." + (match mapping + (($ <file-system-mapping> source target writable?) + (file-system + (mount-point target) + (device source) + (type "none") + (flags (if writable? + '(bind-mount) + '(bind-mount read-only))) + (check? #f) + (create-mount-point? #t))))) + +(define (system-container os) + "Return a derivation that builds OS as a Linux container." + (mlet* %store-monad + ((profile (operating-system-profile os)) + (etc (operating-system-etc-directory os)) + (boot (operating-system-boot-script os #:container? #t)) + (locale (operating-system-locale-directory os))) + (file-union "system-container" + `(("boot" ,#~#$boot) + ("profile" ,#~#$profile) + ("locale" ,#~#$locale) + ("etc" ,#~#$etc))))) + +(define (containerized-operating-system os mappings) + "Return an operating system based on OS for use in a Linux container +environment. MAPPINGS is a list of <file-system-mapping> to realize in the +containerized OS." + (define user-file-systems + (remove (lambda (fs) + (let ((target (file-system-mount-point fs)) + (source (file-system-device fs))) + (or (string=? target (%store-prefix)) + (string=? target "/") + (string-prefix? "/dev/" source) + (string-prefix? "/dev" target) + (string-prefix? "/sys" target)))) + (operating-system-file-systems os))) + + (define (mapping->fs fs) + (file-system (inherit (mapping->file-system fs)) + (needed-for-boot? #t))) + + (operating-system (inherit os) + (swap-devices '()) ; disable swap + (file-systems (append (map mapping->fs (cons %store-mapping mappings)) + %container-file-systems + user-file-systems)))) + +(define* (container-script os #:key (mappings '())) + "Return a derivation of a script that runs OS as a Linux container. +MAPPINGS is a list of <file-system> objects that specify the files/directories +that will be shared with the host system." + (let* ((os (containerized-operating-system os mappings)) + (file-systems (filter file-system-needed-for-boot? + (operating-system-file-systems os))) + (specs (map file-system->spec file-systems))) + + (mlet* %store-monad ((os-drv (system-container os))) + + (define script + #~(begin + (use-modules (gnu build linux-container) + (guix build utils)) + + (call-with-container '#$specs + (lambda () + (setenv "HOME" "/root") + (setenv "TMPDIR" "/tmp") + (setenv "GUIX_NEW_SYSTEM" #$os-drv) + (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var")) + (primitive-load (string-append #$os-drv "/boot")))))) + + (gexp->script "run-container" script + #:modules '((ice-9 match) + (srfi srfi-98) + (guix config) + (guix utils) + (guix build utils) + (guix build syscalls) + (gnu build file-systems) + (gnu build linux-container)))))) |