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. --- gnu/services.scm | 51 +++++++++++++++++++++++++++++++++------ gnu/system.scm | 54 ++++++++++++++++++++++++------------------ gnu/system/linux-container.scm | 18 +++----------- 3 files changed, 78 insertions(+), 45 deletions(-) (limited to 'gnu') diff --git a/gnu/services.scm b/gnu/services.scm index ecf3532e52..8a66d453df 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -60,6 +60,7 @@ (define-module (gnu services) 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 @@ (define-module (gnu services) ;;; 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 @@ (define-syntax modify-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 @@ (define (compute-boot-script _ mexps) ;; 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 @@ (define (etc-directory service) (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 @@ (define etc-service-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 @@ (define (add-edge extension edges) (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 8fed857b39..c26d27028b 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -254,6 +254,24 @@ (define (swap-services os) "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 @@ (define known-fs (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 @@ (define* (operating-system-boot-script os #:key container?) 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 @@ (define (operating-system-parameters-file os) #$(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 c2eb773931..4f38c5cb0a 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -47,20 +47,6 @@ (define (mapping->file-system mapping) (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 @@ (define* (container-script os #:key (mappings '())) (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 -- cgit v1.2.3