diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/file-systems.scm | 15 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 119 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 1 |
3 files changed, 121 insertions, 14 deletions
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index b177f93398..8155b273e3 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -47,7 +47,6 @@ %binary-format-file-system %shared-memory-file-system %pseudo-terminal-file-system - %devtmpfs-file-system %immutable-store %control-groups %elogind-file-systems @@ -186,17 +185,6 @@ UUID representation." (type "binfmt_misc") (check? #f))) -(define %devtmpfs-file-system - ;; /dev as a 'devtmpfs' file system, needed for udev. - (file-system - (device "none") - (mount-point "/dev") - (type "devtmpfs") - (check? #f) - - ;; Mount it from the initrd so /dev/pts & co. can then be mounted over it. - (needed-for-boot? #t))) - (define %tty-gid ;; ID of the 'tty' group. Allocate it statically to make it easy to refer ;; to it from here and from the 'tty' group definitions. @@ -282,8 +270,7 @@ UUID representation." (define %base-file-systems ;; List of basic file systems to be mounted. Note that /proc and /sys are ;; currently mounted by the initrd. - (append (list %devtmpfs-file-system - %pseudo-terminal-file-system + (append (list %pseudo-terminal-file-system %shared-memory-file-system %immutable-store) %elogind-file-systems 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)))))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 48b855b567..519373fe34 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -182,6 +182,7 @@ loaded at boot time in the order in which they appear." "isci" ;for SAS controllers like Intel C602 "usb-storage" "uas" ;for the installation image etc. "usbkbd" "usbhid" ;USB keyboards, for debugging + "dm-crypt" "xts" ;for encrypted root partitions ,@(if (or virtio? qemu-networking?) virtio-modules '()) |