diff options
| -rw-r--r-- | doc/guix.texi | 7 | ||||
| -rw-r--r-- | gnu/services.scm | 59 | ||||
| -rw-r--r-- | gnu/services/version-control.scm | 6 | ||||
| -rw-r--r-- | gnu/system.scm | 7 | ||||
| -rw-r--r-- | gnu/tests/version-control.scm | 2 | ||||
| -rw-r--r-- | tests/services.scm | 32 |
6 files changed, 90 insertions, 23 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 1ecdcd2182..58b9675a3f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10342,9 +10342,8 @@ with the default settings, for commonly encountered log files. (operating-system ;; @dots{} - (services (cons* (service mcron-service-type) - (service rottlog-service-type) - %base-services))) + (services (cons (service rottlog-service-type) + %base-services))) @end lisp @defvr {Scheme Variable} rottlog-service-type @@ -18269,8 +18268,6 @@ The following example will configure the service with default values. By default, Cgit can be accessed on port 80 (@code{http://localhost:80}). @example -(service nginx-service-type) -(service fcgiwrap-service-type) (service cgit-service-type) @end example diff --git a/gnu/services.scm b/gnu/services.scm index 15fc6dcb49..b020d971fd 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -24,6 +24,7 @@ #: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)) @@ -66,6 +67,7 @@ simple-service modify-services service-back-edges + instantiate-missing-services fold-services service-error? @@ -630,6 +632,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 <service>, returns the list of <service> objects that depend on it." @@ -642,16 +656,7 @@ kernel." ((target) (vhash-consq target service edges)) (() - (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)))))))) + (missing-target-error service target-type)) (x (raise (condition (&ambiguous-target-service-error @@ -669,6 +674,38 @@ 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 ((instances (fold (lambda (service result) + (vhash-consq (service-kind service) service + result)) + vlist-null services))) + (fold2 adjust-service-list + services instances + services))) + (define* (fold-services services #:key (target-type system-service-type)) "Fold SERVICES by propagating their extensions down to the root of type diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm index 6bf656949a..7166ed3d4f 100644 --- a/gnu/services/version-control.scm +++ b/gnu/services/version-control.scm @@ -263,7 +263,11 @@ access to exported repositories under @file{/srv/git}." (list (service-extension activation-service-type cgit-activation) (service-extension nginx-service-type - cgit-configuration-nginx-config))) + cgit-configuration-nginx-config) + + ;; Make sure fcgiwrap is instantiated. + (service-extension fcgiwrap-service-type + (const #t)))) (default-value (cgit-configuration)) (description "Run the Cgit web interface, which allows users to browse Git diff --git a/gnu/system.scm b/gnu/system.scm index 40e259f430..39452304ba 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> @@ -492,8 +492,9 @@ a container or that of a \"bare metal\" system." (define* (operating-system-services os #:key container?) "Return all the services of OS, including \"internal\" services that do not explicitly appear in OS." - (append (operating-system-user-services os) - (essential-services os #:container? container?))) + (instantiate-missing-services + (append (operating-system-user-services os) + (essential-services os #:container? container?)))) ;;; diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm index c20e59985e..9882cdbe28 100644 --- a/gnu/tests/version-control.scm +++ b/gnu/tests/version-control.scm @@ -88,8 +88,6 @@ (let ((base-os (simple-operating-system (dhcp-client-service) - (service nginx-service-type) - (service fcgiwrap-service-type) (service cgit-service-type (cgit-configuration (nginx %cgit-configuration-nginx))) diff --git a/tests/services.scm b/tests/services.scm index ca32b565c4..b146a0dec2 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -122,6 +122,36 @@ (fold-services (list s) #:target-type t1) #f))) +(test-assert "instantiate-missing-services" + (let* ((t1 (service-type (name 't1) (extensions '()) + (default-value 'dflt) + (compose concatenate) + (extend cons))) + (t2 (service-type (name 't2) + (extensions + (list (service-extension t1 list))))) + (s1 (service t1 'hey!)) + (s2 (service t2 42))) + (and (lset= equal? + (list (service t1) s2) + (instantiate-missing-services (list s2))) + (equal? (list s1 s2) + (instantiate-missing-services (list s1 s2)))))) + +(test-assert "instantiate-missing-services, no default value" + (let* ((t1 (service-type (name 't1) (extensions '()))) + (t2 (service-type (name 't2) + (extensions + (list (service-extension t1 list))))) + (s (service t2 42))) + (guard (c ((missing-target-service-error? c) + (and (eq? (missing-target-service-error-target-type c) + t1) + (eq? (missing-target-service-error-service c) + s)))) + (instantiate-missing-services (list s)) + #f))) + (test-assert "shepherd-service-lookup-procedure" (let* ((s1 (shepherd-service (provision '(s1 s1b)) (start #f))) (s2 (shepherd-service (provision '(s2 s2b)) (start #f))) |