services: Missing services are automatically instantiated.
This simplifies OS configuration: users no longer need to be aware of what a given service depends on. See the discussion at <https://lists.gnu.org/archive/html/guix-devel/2018-01/msg00114.html>. * gnu/services.scm (missing-target-error): New procedure. (service-back-edges): Use it. (instantiate-missing-services): New procedure. * gnu/system.scm (operating-system-services): Call 'instantiate-missing-services'. * tests/services.scm ("instantiate-missing-services") ("instantiate-missing-services, no default value"): New tests. * gnu/services/version-control.scm (cgit-service-type)[extensions]: Add FCGIWRAP-SERVICE-TYPE. * gnu/tests/version-control.scm (%cgit-os): Remove NGINX-SERVICE-TYPE and FCGIWRAP-SERVICE-TYPE instances. * doc/guix.texi (Log Rotation): Remove 'mcron-service-type' in example. (Miscellaneous Services): Remove 'nginx-service-type' and 'fcgiwrap-service-type' in Cgit example.
This commit is contained in:
Ludovic Courtès
parent
bc58201ec2
commit
d466b1fc82
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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?))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue