diff options
Diffstat (limited to 'gnu')
| -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 |
4 files changed, 57 insertions, 17 deletions
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))) |