From 8e5999e0b0a4f3e639663a803eb99486c3d8304a Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 29 Oct 2015 00:15:36 -0400 Subject: system: container: Adjust to changes in gexps. * gnu/system/linux-container.scm (system-container): 'etc' is no longer a monadic value, and the result of 'file-union' must be lowered. --- gnu/system/linux-container.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'gnu/system/linux-container.scm') diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index fdf746087..abe816f48 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -25,6 +25,7 @@ #:use-module (guix derivations) #:use-module (guix monads) #:use-module (gnu build linux-container) + #:use-module (gnu services) #:use-module (gnu system) #:use-module (gnu system file-systems) #:export (mapping->file-system @@ -50,14 +51,15 @@ "Return a derivation that builds OS as a Linux container." (mlet* %store-monad ((profile (operating-system-profile os)) - (etc (operating-system-etc-directory 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))))) + (lower-object + (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 -- cgit v1.3 From 1c8a81b1af81bdb2fd87efb38004900ad5a77d36 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 8 Jun 2015 09:04:38 -0400 Subject: scripts: system: Add 'container' action. * guix/scripts/system.scm (show-help): Display 'container' action. (system-derivation-for-action, guix-system): Add 'container' case. (perform-action): Skip GRUB config generation when building a container. * doc/guix.texi (Invoking guix system): Document it. --- doc/guix.texi | 21 +++++++++++++++++++++ gnu/system/linux-container.scm | 7 ++++++- guix/scripts/system.scm | 19 +++++++++++++------ 3 files changed, 40 insertions(+), 7 deletions(-) (limited to 'gnu/system/linux-container.scm') diff --git a/doc/guix.texi b/doc/guix.texi index 236c5973c..a23d8244f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7264,6 +7264,27 @@ using the following command: # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc @end example +@item container +Return a script to run the operating system declared in @var{file} +within a container. Containers are a set of lightweight isolation +mechanisms provided by the kernel Linux-libre. Containers are +substantially less resource-demanding than full virtual machines since +the kernel, shared objects, and other resources can be shared with the +host system; this also means they provide thinner isolation. + +Currently, the script must be run as root in order to support more than +a single user and group. The container shares its store with the host +system. + +As with the @code{vm} action (@pxref{guix system vm}), additional file +systems to be shared between the host and container can be specified +using the @option{--share} and @option{--expose} options: + +@example +guix system container my-config.scm \ + --expose=$HOME --share=$HOME/tmp=/exchange +@end example + @end table @var{options} can contain any of the common build options provided by diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index abe816f48..c2eb77393 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -108,7 +108,12 @@ that will be shared with the host system." (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")))))) + (primitive-load (string-append #$os-drv "/boot"))) + ;; A range of 65536 uid/gids is used to cover 16 bits worth of + ;; users and groups, which is sufficient for most cases. + ;; + ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users= + #:host-uids 65536))) (gexp->script "run-container" script #:modules '((ice-9 match) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index d847c7544..499038ffa 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -34,6 +34,7 @@ #:use-module (gnu build install) #:use-module (gnu system) #:use-module (gnu system file-systems) + #:use-module (gnu system linux-container) #:use-module (gnu system vm) #:use-module (gnu system grub) #:use-module (gnu services) @@ -406,6 +407,8 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (case action ((build init reconfigure) (operating-system-derivation os)) + ((container) + (container-script os #:mappings mappings)) ((vm-image) (system-qemu-image os #:disk-image-size image-size)) ((vm) @@ -438,10 +441,12 @@ building anything." #:full-boot? full-boot? #:mappings mappings)) (grub (package->derivation grub)) - (grub.cfg (operating-system-grub.cfg os - (if (eq? 'init action) - '() - (previous-grub-entries)))) + (grub.cfg (if (eq? 'container action) + (return #f) + (operating-system-grub.cfg os + (if (eq? 'init action) + '() + (previous-grub-entries))))) (drvs -> (if (and grub? (memq action '(init reconfigure))) (list sys grub grub.cfg) (list sys))) @@ -523,6 +528,8 @@ Build the operating system declared in FILE according to ACTION.\n")) list-generations list the system generations\n")) (display (_ "\ build build the operating system without installing anything\n")) + (display (_ "\ + container build a container that shares the host's store\n")) (display (_ "\ vm build a virtual machine image that shares the host's store\n")) (display (_ "\ @@ -694,7 +701,7 @@ argument list and OPTS is the option alist." (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build vm vm-image disk-image reconfigure init + ((build container vm vm-image disk-image reconfigure init extension-graph dmd-graph list-generations) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -723,7 +730,7 @@ argument list and OPTS is the option alist." (exit 1)) (case action - ((build vm vm-image disk-image reconfigure) + ((build container vm vm-image disk-image reconfigure) (unless (= count 1) (fail))) ((init) -- cgit v1.3 From d62e201cfd0f1e48c14586489d0e2b80ce943d4f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 2 Nov 2015 18:44:17 +0100 Subject: services: Add 'system-service-type'. * gnu/services.scm (system-derivation): New procedure. (system-service-type): New variable. (boot-script-entry): New procedure. (boot-service-type): Extend SYSTEM-SERVICE-TYPE. (etc-entry): New procedure. (etc-service-type): Extend SYSTEM-SERVICE-TYPE. (fold-services): Change default #:target-type to SYSTEM-SERVICE-TYPE. * gnu/system.scm (operating-system-directory-base-entries): New procedure. (essential-services): Use it. Add an instance of SYSTEM-SERVICE-TYPE. (operating-system-boot-script): Pass #:target-type to 'fold-services'. (operating-system-derivation): Rewrite in terms of 'fold-services'. * gnu/system/linux-container.scm (system-container): Remove. (container-script): Use 'operating-system-derivation'. * guix/scripts/system.scm (export-extension-graph): Replace BOOT-SERVICE-TYPE by SYSTEM-SERVICE-TYPE. * doc/images/service-graph.dot: Add 'system' node and edges. * doc/guix.texi (Service Composition): Mention SYSTEM-SERVICE-TYPE. (Service Reference): Document it. Update 'fold-services' documentation. --- doc/guix.texi | 26 +++++++++++++------- doc/images/service-graph.dot | 5 +++- gnu/services.scm | 51 +++++++++++++++++++++++++++++++++------ gnu/system.scm | 54 ++++++++++++++++++++++++------------------ gnu/system/linux-container.scm | 18 +++----------- guix/scripts/system.scm | 6 ++--- 6 files changed, 103 insertions(+), 57 deletions(-) (limited to 'gnu/system/linux-container.scm') diff --git a/doc/guix.texi b/doc/guix.texi index 74e0977db..6ab98deef 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7589,8 +7589,11 @@ as arrows, a typical system might provide something like this: @image{images/service-graph,,5in,Typical service extension graph.} -At the bottom, we see the @dfn{boot service}, which produces the boot -script that is executed at boot time from the initial RAM disk. +@cindex system service +At the bottom, we see the @dfn{system service}, which produces the +directory containing everything to run and boot the system, as returned +by the @command{guix system build} command. @xref{Service Reference}, +to learn about the other service types shown here. @xref{system-extension-graph, the @command{guix system extension-graph} command}, for information on how to generate this representation for a particular operating system definition. @@ -7853,12 +7856,14 @@ Return true if @var{obj} is a service extension. At the core of the service abstraction lies the @code{fold-services} procedure, which is responsible for ``compiling'' a list of services -down to a single boot script. In essence, it propagates service -extensions down the service graph, updating each node parameters on the -way, until it reaches the root node. +down to a single directory that contains everything needed to boot and +run the system---the directory shown by the @command{guix system build} +command (@pxref{Invoking guix system}). In essence, it propagates +service extensions down the service graph, updating each node parameters +on the way, until it reaches the root node. @deffn {Scheme Procedure} fold-services @var{services} @ - [#:target-type @var{boot-service-type}] + [#:target-type @var{system-service-type}] Fold @var{services} by propagating their extensions down to the root of type @var{target-type}; return the root service adjusted accordingly. @end deffn @@ -7866,9 +7871,14 @@ type @var{target-type}; return the root service adjusted accordingly. Lastly, the @code{(gnu services)} module also defines several essential service types, some of which are listed below. +@defvr {Scheme Variable} system-service-type +This is the root of the service graph. It produces the system directory +as returned by the @command{guix system build} command. +@end defvr + @defvr {Scheme Variable} boot-service-type -The type of the ``boot service'', which is the root of the service -graph. +The type of the ``boot service'', which produces the @dfn{boot script}. +The boot script is what the initial RAM disk runs when booting. @end defvr @defvr {Scheme Variable} etc-service-type diff --git a/doc/images/service-graph.dot b/doc/images/service-graph.dot index 3397b878e..04f231bb0 100644 --- a/doc/images/service-graph.dot +++ b/doc/images/service-graph.dot @@ -4,7 +4,8 @@ digraph "Service Type Dependencies" { etc [shape = box, fontname = Helvetica]; accounts [shape = box, fontname = Helvetica]; activation [shape = box, fontname = Helvetica]; - boot [shape = house, fontname = Helvetica]; + boot [shape = box, fontname = Helvetica]; + system [shape = house, fontname = Helvetica]; lshd -> dmd; lshd -> pam; udev -> dmd; @@ -32,4 +33,6 @@ digraph "Service Type Dependencies" { guix -> dmd; guix -> activation; guix -> accounts; + boot -> system; + etc -> system; } diff --git a/gnu/services.scm b/gnu/services.scm index ecf3532e5..8a66d453d 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -60,6 +60,7 @@ ambiguous-target-service-error-service ambiguous-target-service-error-target-type + system-service-type boot-service-type activation-service-type activation-service->script @@ -89,9 +90,10 @@ ;;; by providing one procedure to compose extensions, and one procedure to ;;; extend itself. ;;; -;;; A notable service type is BOOT-SERVICE-TYPE, which has a single instance, -;;; %BOOT-SERVICE. %BOOT-SERVICE constitutes the root of the service DAG. It -;;; produces the boot script that the initrd loads. +;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single +;;; instance, which is the root of the service DAG. Its value is the +;;; derivation that produces the 'system' directory as returned by +;;; 'operating-system-derivation'. ;;; ;;; The 'fold-services' procedure can be passed a list of procedures, which it ;;; "folds" by propagating extensions down the graph; it returns the root @@ -182,6 +184,25 @@ This is a shorthand for (map (lambda (svc) ...) %base-services)." ;;; Core services. ;;; +(define (system-derivation mentries mextensions) + "Return as a monadic value the derivation of the 'system' directory +containing the given entries." + (mlet %store-monad ((entries mentries) + (extensions (sequence %store-monad mextensions))) + (lower-object + (file-union "system" + (append entries (concatenate extensions)))))) + +(define system-service-type + ;; This is the ultimate service type, the root of the service DAG. The + ;; service of this type is extended by monadic name/item pairs. These items + ;; end up in the "system directory" as returned by + ;; 'operating-system-derivation'. + (service-type (name 'system) + (extensions '()) + (compose identity) + (extend system-derivation))) + (define (compute-boot-script _ mexps) (mlet %store-monad ((gexps (sequence %store-monad mexps))) (gexp->file "boot" @@ -203,17 +224,25 @@ This is a shorthand for (map (lambda (svc) ...) %base-services)." ;; Activate the system and spawn dmd. #$@gexps)))) +(define (boot-script-entry mboot) + "Return, as a monadic value, an entry for the boot script in the system +directory." + (mlet %store-monad ((boot mboot)) + (return `(("boot" ,boot))))) + (define boot-service-type ;; The service of this type is extended by being passed gexps as monadic ;; values. It aggregates them in a single script, as a monadic value, which ;; becomes its 'parameters'. It is the only service that extends nothing. (service-type (name 'boot) - (extensions '()) + (extensions + (list (service-extension system-service-type + boot-script-entry))) (compose append) (extend compute-boot-script))) (define %boot-service - ;; This is the ultimate service, the root of the service DAG. + ;; The service that produces the boot script. (service boot-service-type #t)) (define* (file-union name files) ;FIXME: Factorize. @@ -351,6 +380,12 @@ ACTIVATION-SCRIPT-TYPE." (define (files->etc-directory files) (file-union "etc" files)) +(define (etc-entry files) + "Return an entry for the /etc directory consisting of FILES in the system +directory." + (with-monad %store-monad + (return `(("etc" ,(files->etc-directory files)))))) + (define etc-service-type (service-type (name 'etc) (extensions @@ -359,7 +394,8 @@ ACTIVATION-SCRIPT-TYPE." (lambda (files) (let ((etc (files->etc-directory files))) - #~(activate-etc #$etc)))))) + #~(activate-etc #$etc)))) + (service-extension system-service-type etc-entry))) (compose concatenate) (extend append))) @@ -450,7 +486,8 @@ kernel." (lambda (node) (reverse (vhash-foldq* cons '() node edges))))) -(define* (fold-services services #:key (target-type boot-service-type)) +(define* (fold-services services + #:key (target-type system-service-type)) "Fold SERVICES by propagating their extensions down to the root of type TARGET-TYPE; return the root service adjusted accordingly." (define dependents diff --git a/gnu/system.scm b/gnu/system.scm index 8fed857b3..c26d27028 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -254,6 +254,24 @@ from the initrd." "Return the list of swap services for OS." (map swap-service (operating-system-swap-devices os))) +(define* (operating-system-directory-base-entries os #:key container?) + "Return the basic entries of the 'system' directory of OS for use as the +value of the SYSTEM-SERVICE-TYPE service." + (mlet* %store-monad ((profile (operating-system-profile os)) + (locale (operating-system-locale-directory os))) + (if container? + (return `(("profile" ,profile) + ("locale" ,locale))) + (mlet %store-monad + ((kernel -> (operating-system-kernel os)) + (initrd (operating-system-initrd-file os)) + (params (operating-system-parameters-file os))) + (return `(("kernel" ,kernel) + ("parameters" ,params) + ("initrd" ,initrd) + ("profile" ,profile) + ("locale" ,locale))))))) ;used by libc + (define* (essential-services os #:key container?) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level @@ -269,8 +287,11 @@ a container or that of a \"bare metal\" system." (swaps (swap-services os)) (procs (user-processes-service (map service-parameters other-fs))) - (host-name (host-name-service (operating-system-host-name os)))) - (cons* %boot-service + (host-name (host-name-service (operating-system-host-name os))) + (entries (operating-system-directory-base-entries + os #:container? container?))) + (cons* (service system-service-type entries) + %boot-service ;; %DMD-ROOT-SERVICE must come first so that the gexp that execs ;; dmd comes last in the boot script (XXX). @@ -607,10 +628,17 @@ etc." we're running in the final root. When CONTAINER? is true, skip all hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os #:container? container?)) - (boot (fold-services services))) + (boot (fold-services services #:target-type boot-service-type))) ;; BOOT is the script as a monadic value. (service-parameters boot))) +(define* (operating-system-derivation os #:key container?) + "Return a derivation that builds OS." + (let* ((services (operating-system-services os #:container? container?)) + (system (fold-services services))) + ;; SYSTEM contains the derivation as a monadic value. + (service-parameters system))) + (define (operating-system-root-file-system os) "Return the root file system of OS." (find (match-lambda @@ -693,24 +721,4 @@ this file is the reconstruction of GRUB menu entries for old configurations." #$(operating-system-kernel-arguments os)) (initrd #$initrd))))) -(define (operating-system-derivation os) - "Return a derivation that builds OS." - (mlet* %store-monad - ((profile (operating-system-profile os)) - (etc -> (operating-system-etc-directory os)) - (boot (operating-system-boot-script os)) - (kernel -> (operating-system-kernel os)) - (initrd (operating-system-initrd-file os)) - (locale (operating-system-locale-directory os)) - (params (operating-system-parameters-file os))) - (lower-object - (file-union "system" - `(("boot" ,#~#$boot) - ("kernel" ,#~#$kernel) - ("parameters" ,#~#$params) - ("initrd" ,initrd) - ("profile" ,#~#$profile) - ("locale" ,#~#$locale) ;used by libc - ("etc" ,#~#$etc)))))) - ;;; system.scm ends here diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index c2eb77393..4f38c5cb0 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -47,20 +47,6 @@ (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))) - (lower-object - (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 to realize in the @@ -95,7 +81,9 @@ that will be shared with the host system." (operating-system-file-systems os))) (specs (map file-system->spec file-systems))) - (mlet* %store-monad ((os-drv (system-container os))) + (mlet* %store-monad ((os-drv (operating-system-derivation + os + #:container? #t))) (define script #~(begin diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7be734785..7a8a751df 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -491,10 +491,10 @@ building anything." (define (export-extension-graph os port) "Export the service extension graph of OS to PORT." (let* ((services (operating-system-services os)) - (boot (find (lambda (service) - (eq? (service-kind service) boot-service-type)) + (system (find (lambda (service) + (eq? (service-kind service) system-service-type)) services))) - (export-graph (list boot) (current-output-port) + (export-graph (list system) (current-output-port) #:node-type (service-node-type services) #:reverse-edges? #t))) -- cgit v1.3