X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/a3b84f70d8bc992a0fc38cabdf12d48ff5e10e15..6a7ac0a829169f665c0aee6cb7899fa943b2d648:/gnu/services.scm diff --git a/gnu/services.scm b/gnu/services.scm index 9268c51dd8..394470ba7d 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich ;;; ;;; This file is part of GNU Guix. @@ -23,8 +23,12 @@ #:use-module (guix store) #:use-module (guix records) #:use-module (guix profiles) + #:use-module (guix discovery) + #:use-module (guix combinators) #:use-module (guix sets) #:use-module (guix ui) + #:use-module ((guix utils) #:select (source-properties->location)) + #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (srfi srfi-1) @@ -37,6 +41,8 @@ #:use-module (ice-9 match) #:export (service-extension service-extension? + service-extension-target + service-extension-compute service-type service-type? @@ -44,17 +50,30 @@ service-type-extensions service-type-compose service-type-extend + service-type-default-value + service-type-description + service-type-location + + %service-type-path + fold-service-types + lookup-service-types service service? service-kind - service-parameters + service-value + service-parameters ;deprecated + simple-service modify-services service-back-edges + instantiate-missing-services fold-services service-error? + missing-value-service-error? + missing-value-service-error-type + missing-value-service-error-location missing-target-service-error? missing-target-service-error-service missing-target-service-error-target-type @@ -68,17 +87,18 @@ activation-service-type activation-service->script %linux-bare-metal-service + special-files-service-type + extra-special-file etc-service-type etc-directory setuid-program-service-type profile-service-type firmware-service-type + gc-root-service-type %boot-service %activation-service - etc-service - - file-union)) ;XXX: for lack of a better place + etc-service)) ;;; Comment: ;;; @@ -111,6 +131,10 @@ (target service-extension-target) ; (compute service-extension-compute)) ;params -> params +(define &no-default-value + ;; Value used to denote service types that have no associated default value. + '(no default value)) + (define-record-type* service-type make-service-type service-type? (name service-type-name) ;symbol (for debugging) @@ -124,7 +148,19 @@ ;; Extend the services' own parameters with the extension composition. (extend service-type-extend ;list of Any -> parameters - (default #f))) + (default #f)) + + ;; Optional default value for instances of this type. + (default-value service-type-default-value ;Any + (default &no-default-value)) + + ;; Meta-data. + (description service-type-description ;string + (default #f)) + (location service-type-location ; + (default (and=> (current-source-location) + source-properties->location)) + (innate))) (define (write-service-type type port) (format port "#" @@ -133,13 +169,103 @@ (set-record-type-printer! write-service-type) +(define %distro-root-directory + ;; Absolute file name of the module hierarchy. + (dirname (search-path %load-path "guix.scm"))) + +(define %service-type-path + ;; Search path for service types. + (make-parameter `((,%distro-root-directory . "gnu/services") + (,%distro-root-directory . "gnu/system")))) + +(define (all-service-modules) + "Return the default set of service modules." + (cons (resolve-interface '(gnu services)) + (all-modules (%service-type-path) + #:warn warn-about-load-error))) + +(define* (fold-service-types proc seed + #:optional + (modules (all-service-modules))) + "For each service type exported by one of MODULES, call (PROC RESULT). SEED +is used as the initial value of RESULT." + (fold-module-public-variables (lambda (object result) + (if (service-type? object) + (proc object result) + result)) + seed + modules)) + +(define lookup-service-types + (let ((table + (delay (fold-service-types (lambda (type result) + (vhash-consq (service-type-name type) + type result)) + vlist-null)))) + (lambda (name) + "Return the list of services with the given NAME (a symbol)." + (vhash-foldq* cons '() name (force table))))) + ;; Services of a given type. (define-record-type - (service type parameters) + (make-service type value) service? (type service-kind) - (parameters service-parameters)) + (value service-value)) + +(define-syntax service + (syntax-rules () + "Return a service instance of TYPE. The service value is VALUE or, if +omitted, TYPE's default value." + ((_ type value) + (make-service type value)) + ((_ type) + (%service-with-default-value (current-source-location) + type)))) + +(define (%service-with-default-value location type) + "Return a instance of service type TYPE with its default value, if any. If +TYPE does not have a default value, an error is raised." + ;; TODO: Currently this is a run-time error but with a little bit macrology + ;; we could turn it into an expansion-time error. + (let ((default (service-type-default-value type))) + (if (eq? default &no-default-value) + (let ((location (source-properties->location location))) + (raise + (condition + (&missing-value-service-error (type type) (location location)) + (&message + (message (format #f (G_ "~a: no value specified \ +for service of type '~a'") + (location->string location) + (service-type-name type))))))) + (service type default)))) + +(define-condition-type &service-error &error + service-error?) + +(define-condition-type &missing-value-service-error &service-error + missing-value-service-error? + (type missing-value-service-error-type) + (location missing-value-service-error-location)) + + +;;; +;;; Helpers. +;;; + +(define service-parameters + ;; Deprecated alias. + service-value) + +(define (simple-service name target value) + "Return a service that extends TARGET with VALUE. This works by creating a +singleton service type NAME, of which the returned service is an instance." + (let* ((extension (service-extension target identity)) + (type (service-type (name name) + (extensions (list extension))))) + (service type value))) (define-syntax %modify-service (syntax-rules (=>) @@ -147,7 +273,7 @@ service) ((_ svc (kind param => exp ...) clauses ...) (if (eq? (service-kind svc) kind) - (let ((param (service-parameters svc))) + (let ((param (service-value svc))) (service (service-kind svc) (begin exp ...))) (%modify-service svc clauses ...))))) @@ -205,13 +331,20 @@ containing the given entries." (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" - ;; Clean up and activate the system, then spawn shepherd. - #~(begin #$@gexps)))) + (extend system-derivation) + (description + "Build the operating system top-level directory, which in +turn refers to everything the operating system needs: its kernel, initrd, +system profile, boot script, and so on."))) + +(define (compute-boot-script _ gexps) + ;; Reverse GEXPS so that extensions appear in the boot script in the right + ;; order. That is, user extensions would come first, and extensions added + ;; by 'essential-services' (e.g., running shepherd) are guaranteed to come + ;; last. + (gexp->file "boot" + ;; Clean up and activate the system, then spawn shepherd. + #~(begin #$@(reverse gexps)))) (define (boot-script-entry mboot) "Return, as a monadic value, an entry for the boot script in the system @@ -220,150 +353,115 @@ directory." (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. + ;; The service of this type is extended by being passed gexps. It + ;; aggregates them in a single script, as a monadic value, which becomes its + ;; value. (service-type (name 'boot) (extensions (list (service-extension system-service-type boot-script-entry))) - (compose append) - (extend compute-boot-script))) + (compose identity) + (extend compute-boot-script) + (description + "Produce the operating system's boot script, which is spawned +by the initrd once the root file system is mounted."))) (define %boot-service ;; The service that produces the boot script. (service boot-service-type #t)) (define (cleanup-gexp _) - "Return as a monadic value a gexp to clean up /tmp and similar places upon -boot." - (define %modules - '((guix build utils))) - - (mlet %store-monad ((modules (imported-modules %modules)) - (compiled (compiled-modules %modules))) - (return #~(begin - (eval-when (expand load eval) - ;; Make sure 'use-modules' below succeeds. - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - - (use-modules (guix build utils)) - - ;; Clean out /tmp and /var/run. - ;; - ;; XXX This needs to happen before service activations, so it - ;; has to be here, but this also implicitly assumes that /tmp - ;; and /var/run are on the root partition. - (letrec-syntax ((fail-safe (syntax-rules () - ((_ exp rest ...) - (begin - (catch 'system-error - (lambda () exp) - (const #f)) - (fail-safe rest ...))) - ((_) - #t)))) - ;; Ignore I/O errors so the system can boot. - (fail-safe - (delete-file-recursively "/tmp") - (delete-file-recursively "/var/run") - (mkdir "/tmp") - (chmod "/tmp" #o1777) - (mkdir "/var/run") - (chmod "/var/run" #o755))))))) + "Return a gexp to clean up /tmp and similar places upon boot." + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + ;; Clean out /tmp and /var/run. + ;; + ;; XXX This needs to happen before service activations, so it + ;; has to be here, but this also implicitly assumes that /tmp + ;; and /var/run are on the root partition. + (letrec-syntax ((fail-safe (syntax-rules () + ((_ exp rest ...) + (begin + (catch 'system-error + (lambda () exp) + (const #f)) + (fail-safe rest ...))) + ((_) + #t)))) + ;; Ignore I/O errors so the system can boot. + (fail-safe + ;; Remove stale Shadow lock files as they would lead to + ;; failures of 'useradd' & co. + (delete-file "/etc/group.lock") + (delete-file "/etc/passwd.lock") + (delete-file "/etc/.pwd.lock") ;from 'lckpwdf' + + ;; Force file names to be decoded as UTF-8. See + ;; . + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_CTYPE "en_US.utf8") + (delete-file-recursively "/tmp") + (delete-file-recursively "/var/run") + + (mkdir "/tmp") + (chmod "/tmp" #o1777) + (mkdir "/var/run") + (chmod "/var/run" #o755) + (delete-file-recursively "/run/udev/watch.old")))))) (define cleanup-service-type ;; Service that cleans things up in /tmp and similar. (service-type (name 'cleanup) (extensions (list (service-extension boot-service-type - cleanup-gexp))))) - -(define* (file-union name files) ;FIXME: Factorize. - "Return a that builds a directory containing all of FILES. -Each item in FILES must be a list where the first element is the file name to -use in the new directory, and the second element is a gexp denoting the target -file." - (computed-file name - #~(begin - (mkdir #$output) - (chdir #$output) - #$@(map (match-lambda - ((target source) - #~(begin - ;; Stat the source to abort early if it - ;; does not exist. - (stat #$source) - - (symlink #$source #$target)))) - files)))) - -(define (directory-union name things) - "Return a directory that is the union of THINGS." - (match things - ((one) - ;; Only one thing; return it. - one) - (_ - (computed-file name - #~(begin - (use-modules (guix build union)) - (union-build #$output '#$things)) - #:modules '((guix build union)))))) + cleanup-gexp))) + (description + "Delete files from @file{/tmp}, @file{/var/run}, and other +temporary locations at boot time."))) (define* (activation-service->script service) "Return as a monadic value the activation script for SERVICE, a service of ACTIVATION-SCRIPT-TYPE." - (activation-script (service-parameters service))) + (activation-script (service-value service))) (define (activation-script gexps) "Return the system's activation script, which evaluates GEXPS." - (define %modules - '((gnu build activation) - (gnu build linux-boot) - (gnu build linux-modules) - (gnu build file-systems) - (guix build utils) - (guix build syscalls) - (guix build bournish) - (guix elf))) - - (define (service-activations) - ;; Return the activation scripts for SERVICES. - (mapm %store-monad - (cut gexp->file "activate-service" <>) - gexps)) - - (mlet* %store-monad ((actions (service-activations)) - (modules (imported-modules %modules)) - (compiled (compiled-modules %modules))) - (gexp->file "activate" - #~(begin - (eval-when (expand load eval) - ;; Make sure 'use-modules' below succeeds. - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - - (use-modules (gnu build activation)) - - ;; Make sure /bin/sh is valid and current. - (activate-/bin/sh - (string-append #$(canonical-package bash) "/bin/sh")) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions) - - ;; Set up /run/current-system. - (activate-current-system))))) + (define actions + (map (cut program-file "activate-service.scm" <>) gexps)) + + (program-file "activate.scm" + (with-imported-modules (source-module-closure + '((gnu build activation) + (guix build utils))) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If it + ;; does not exist, 'setutxent' does not create it and + ;; thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things this + ;; sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." - (mlet %store-monad ((script (activation-script gexps))) - (return #~(primitive-load #$script)))) + #~(primitive-load #$(activation-script gexps))) (define (second-argument a b) b) @@ -372,8 +470,11 @@ ACTIVATION-SCRIPT-TYPE." (extensions (list (service-extension boot-service-type gexps->activation-gexp))) - (compose append) - (extend second-argument))) + (compose identity) + (extend second-argument) + (description + "Run @dfn{activation} code at boot time and upon +@command{guix system reconfigure} completion."))) (define %activation-service ;; The activation service produces the activation script from the gexps it @@ -404,20 +505,39 @@ ACTIVATION-SCRIPT-TYPE." ;; Let users debug their own processes! (activate-ptrace-attach))) -(define linux-bare-metal-service-type - (service-type (name 'linux-bare-metal) - (extensions - (list (service-extension activation-service-type - (const %linux-kernel-activation)))))) - (define %linux-bare-metal-service ;; The service that does things that are needed on the "bare metal", but not ;; necessary or impossible in a container. - (service linux-bare-metal-service-type #f)) + (simple-service 'linux-bare-metal + activation-service-type + %linux-kernel-activation)) + + +(define special-files-service-type + ;; Service to install "special files" such as /bin/sh and /usr/bin/env. + (service-type + (name 'special-files) + (extensions + (list (service-extension activation-service-type + (lambda (files) + #~(activate-special-files '#$files))))) + (compose concatenate) + (extend append) + (description + "Add special files to the root file system---e.g., +@file{/usr/bin/env}."))) + +(define (extra-special-file file target) + "Use TARGET as the \"special file\" FILE. For example, TARGET might be + (file-append coreutils \"/bin/env\") +and FILE could be \"/usr/bin/env\"." + (simple-service (string->symbol (string-append "special-file-" file)) + special-files-service-type + `((,file ,target)))) (define (etc-directory service) "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE." - (files->etc-directory (service-parameters service))) + (files->etc-directory (service-value service))) (define (files->etc-directory files) (file-union "etc" files)) @@ -439,7 +559,8 @@ directory." #~(activate-etc #$etc)))) (service-extension system-service-type etc-entry))) (compose concatenate) - (extend append))) + (extend append) + (description "Populate the @file{/etc} directory."))) (define (etc-service files) "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES. @@ -454,7 +575,10 @@ FILES must be a list of name/file-like object pairs." #~(activate-setuid-programs (list #$@programs)))))) (compose concatenate) - (extend append))) + (extend append) + (description + "Populate @file{/run/setuid-programs} with the specified +executables, making them setuid-root."))) (define (packages->profile-entry packages) "Return a system entry for the profile containing PACKAGES." @@ -471,7 +595,11 @@ FILES must be a list of name/file-like object pairs." (list (service-extension system-service-type packages->profile-entry))) (compose concatenate) - (extend append))) + (extend append) + (description + "This is the @dfn{system profile}, available as +@file{/run/current-system/profile}. It contains packages that the sysadmin +wants to be globally available to all the system users."))) (define (firmware->activation-gexp firmware) "Return a gexp to make the packages listed in FIRMWARE loadable by the @@ -487,16 +615,48 @@ kernel." (list (service-extension activation-service-type firmware->activation-gexp))) (compose concatenate) - (extend append))) + (extend append) + (description + "Make ``firmware'' files loadable by the operating system +kernel. Firmware may then be uploaded to some of the machine's devices, such +as Wifi cards."))) + +(define (gc-roots->system-entry roots) + "Return an entry in the system's output containing symlinks to ROOTS." + (mlet %store-monad ((entry (gexp->derivation + "gc-roots" + #~(let ((roots '#$roots)) + (mkdir #$output) + (chdir #$output) + (for-each symlink + roots + (map number->string + (iota (length roots)))))))) + (return (if (null? roots) + '() + `(("gc-roots" ,entry)))))) + +(define gc-root-service-type + ;; A service to associate extra garbage-collector roots to the system. This + ;; is a simple hack that guarantees that the system retains references to + ;; the given list of roots. Roots must be "lowerable" objects like + ;; packages, or derivations. + (service-type (name 'gc-roots) + (extensions + (list (service-extension system-service-type + gc-roots->system-entry))) + (compose concatenate) + (extend append) + (description + "Register garbage-collector roots---i.e., store items that +will not be reclaimed by the garbage collector.") + (default-value '()))) ;;; ;;; Service folding. ;;; -(define-condition-type &service-error &error - service-error?) - (define-condition-type &missing-target-service-error &service-error missing-target-service-error? (service missing-target-service-error-service) @@ -507,6 +667,18 @@ kernel." (service ambiguous-target-service-error-service) (target-type ambiguous-target-service-error-target-type)) +(define (missing-target-error service target-type) + (raise + (condition (&missing-target-service-error + (service service) + (target-type target-type)) + (&message + (message + (format #f (G_ "no target of type '~a' for service '~a'") + (service-type-name target-type) + (service-type-name + (service-kind service)))))))) + (define (service-back-edges services) "Return a procedure that, when passed a , returns the list of objects that depend on it." @@ -519,15 +691,7 @@ kernel." ((target) (vhash-consq target service edges)) (() - (raise - (condition (&missing-target-service-error - (service service) - (target-type target-type)) - (&message - (message - (format #f (_ "no target of type '~a' for service ~s") - (service-type-name target-type) - service)))))) + (missing-target-error service target-type)) (x (raise (condition (&ambiguous-target-service-error @@ -536,7 +700,7 @@ kernel." (&message (message (format #f - (_ "more than one target service of type '~a'") + (G_ "more than one target service of type '~a'") (service-type-name target-type)))))))))) (fold add-edge edges (service-type-extensions (service-kind service)))) @@ -545,6 +709,48 @@ kernel." (lambda (node) (reverse (vhash-foldq* cons '() node edges))))) +(define (instantiate-missing-services services) + "Return SERVICES, a list, augmented with any services targeted by extensions +and missing from SERVICES. Only service types with a default value can be +instantiated; other missing services lead to a +'&missing-target-service-error'." + (define (adjust-service-list svc result instances) + (fold2 (lambda (extension result instances) + (define target-type + (service-extension-target extension)) + + (match (vhash-assq target-type instances) + (#f + (let ((default (service-type-default-value target-type))) + (if (eq? &no-default-value default) + (missing-target-error svc target-type) + (let ((new (service target-type))) + (values (cons new result) + (vhash-consq target-type new instances)))))) + (_ + (values result instances)))) + result + instances + (service-type-extensions (service-kind svc)))) + + (let loop ((services services)) + (define instances + (fold (lambda (service result) + (vhash-consq (service-kind service) service + result)) + vlist-null services)) + + (define adjusted + (fold2 adjust-service-list + services instances + services)) + + ;; If we instantiated services, they might in turn depend on missing + ;; services. Loop until we've reached fixed point. + (if (= (length adjusted) (vlist-length instances)) + adjusted + (loop adjusted)))) + (define* (fold-services services #:key (target-type system-service-type)) "Fold SERVICES by propagating their extensions down to the root of type @@ -563,31 +769,47 @@ TARGET-TYPE; return the root service adjusted accordingly." (match (find (matching-extension target) (service-type-extensions (service-kind service))) (($ _ compute) - (compute (service-parameters service)))))) + (compute (service-value service)))))) (match (filter (lambda (service) (eq? (service-kind service) target-type)) services) ((sink) - (let loop ((sink sink)) - (let* ((dependents (map loop (dependents sink))) - (extensions (map (apply-extension sink) dependents)) - (extend (service-type-extend (service-kind sink))) - (compose (service-type-compose (service-kind sink))) - (params (service-parameters sink))) - ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a - ;; different type than the elements of EXTENSIONS. - (if extend - (service (service-kind sink) - (extend params (compose extensions))) - sink)))) + ;; Use the state monad to keep track of already-visited services in the + ;; graph and to memoize their value once folded. + (run-with-state + (let loop ((sink sink)) + (mlet %state-monad ((visited (current-state))) + (match (vhash-assq sink visited) + (#f + (mlet* %state-monad + ((dependents (mapm %state-monad loop (dependents sink))) + (visited (current-state)) + (extensions -> (map (apply-extension sink) dependents)) + (extend -> (service-type-extend (service-kind sink))) + (compose -> (service-type-compose (service-kind sink))) + (params -> (service-value sink)) + (service + -> + ;; Distinguish COMPOSE and EXTEND because PARAMS typically + ;; has a different type than the elements of EXTENSIONS. + (if extend + (service (service-kind sink) + (extend params (compose extensions))) + sink))) + (mbegin %state-monad + (set-current-state (vhash-consq sink service visited)) + (return service)))) + ((_ . service) ;SINK was already visited + (return service))))) + vlist-null)) (() (raise (condition (&missing-target-service-error (service #f) (target-type target-type)) (&message - (message (format #f (_ "service of type '~a' not found") + (message (format #f (G_ "service of type '~a' not found") (service-type-name target-type))))))) (x (raise @@ -597,7 +819,7 @@ TARGET-TYPE; return the root service adjusted accordingly." (&message (message (format #f - (_ "more than one target service of type '~a'") + (G_ "more than one target service of type '~a'") (service-type-name target-type))))))))) ;;; services.scm ends here.