From mboxrd@z Thu Jan 1 00:00:00 1970 From: David Thompson Subject: [PATCH 11/15] gnu: system: Add Linux container module. Date: Mon, 6 Jul 2015 09:16:40 -0400 Message-ID: <1436188604-2813-11-git-send-email-dthompson2@worcester.edu> References: <1436188604-2813-1-git-send-email-dthompson2@worcester.edu> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:47604) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZC6HA-0001YE-T1 for guix-devel@gnu.org; Mon, 06 Jul 2015 09:17:43 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ZC6H6-0006yE-Dv for guix-devel@gnu.org; Mon, 06 Jul 2015 09:17:36 -0400 Received: from mail-qk0-f180.google.com ([209.85.220.180]:35826) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZC6H6-0006xz-9s for guix-devel@gnu.org; Mon, 06 Jul 2015 09:17:32 -0400 Received: by qkbp125 with SMTP id p125so116383421qkb.2 for ; Mon, 06 Jul 2015 06:17:32 -0700 (PDT) In-Reply-To: <1436188604-2813-1-git-send-email-dthompson2@worcester.edu> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: guix-devel@gnu.org Cc: David Thompson From: David Thompson * gnu/system/linux-container.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. * gnu/system.scm: Export 'operating-system-etc-directory', 'operating-system-boot-script', 'operating-system-locale-directory', and 'file-union'. (operating-system-boot-script): Add #:container? keyword argument. (operating-system-activation-script): Add #:container? keyword argument. Don't call 'activate-firmware' or 'activate-ptrace-attach' when activating a container. --- gnu-system.am | 1 + gnu/system.scm | 27 ++++++++----- gnu/system/linux-container.scm | 90 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 109 insertions(+), 9 deletions(-) create mode 100644 gnu/system/linux-container.scm diff --git a/gnu-system.am b/gnu-system.am index 48dbc5f..cfc2999 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -346,6 +346,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 82b7fbc..476d901 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -82,6 +82,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 @@ -679,7 +684,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." @@ -752,12 +757,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'. @@ -766,11 +774,12 @@ 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." (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 0000000..5368dec --- /dev/null +++ b/gnu/system/linux-container.scm @@ -0,0 +1,90 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson +;;; +;;; 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 . + +(define-module (gnu system linux-container) + #:use-module (ice-9 match) + #: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 + container-script)) + +(define (mapping->file-system mapping) + "Return a file system that realizes MAPPING." + (match 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) + (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* (container-script os #:key (mappings '())) + (let* ((mappings (map mapping->file-system + ;; Bind-mount the store in addition to + ;; user-specified mappings. + (cons %store-mapping mappings))) + (file-systems (filter file-system-needed-for-boot? + (operating-system-file-systems os))) + (specs (map file-system->spec + (append file-systems mappings)))) + + (mlet* %store-monad ((os-drv (system-container os))) + + (define script + #~(begin + (use-modules (gnu build linux-container)) + + (call-with-container '#$specs + (lambda () + (setenv "HOME" "/root") + (setenv "TMPDIR" "/tmp") + (setenv "GUIX_NEW_SYSTEM" #$os-drv) + (for-each mkdir '("/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 linux-container)))))) -- 2.4.3