services: shepherd: Add 'shepherd-service-lookup-procedure'.
* gnu/services/shepherd.scm (shepherd-service-lookup-procedure): New procedure. (shepherd-service-back-edges)[provision->service]: Use it. * tests/services.scm ("shepherd-service-lookup-procedure"): New test.
This commit is contained in:
parent
b8692e4696
commit
a5d78eb64b
|
@ -52,6 +52,7 @@
|
||||||
|
|
||||||
shepherd-service-file
|
shepherd-service-file
|
||||||
|
|
||||||
|
shepherd-service-lookup-procedure
|
||||||
shepherd-service-back-edges))
|
shepherd-service-back-edges))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
|
@ -249,20 +250,29 @@ stored."
|
||||||
|
|
||||||
(gexp->file "shepherd.conf" config)))
|
(gexp->file "shepherd.conf" config)))
|
||||||
|
|
||||||
|
(define* (shepherd-service-lookup-procedure services
|
||||||
|
#:optional
|
||||||
|
(provision
|
||||||
|
shepherd-service-provision))
|
||||||
|
"Return a procedure that, when passed a symbol, return the item among
|
||||||
|
SERVICES that provides this symbol. PROVISION must be a one-argument
|
||||||
|
procedure that takes a service and returns the list of symbols it provides."
|
||||||
|
(let ((services (fold (lambda (service result)
|
||||||
|
(fold (cut vhash-consq <> service <>)
|
||||||
|
result
|
||||||
|
(provision service)))
|
||||||
|
vlist-null
|
||||||
|
services)))
|
||||||
|
(lambda (name)
|
||||||
|
(match (vhash-assq name services)
|
||||||
|
((_ . service) service)
|
||||||
|
(#f #f)))))
|
||||||
|
|
||||||
(define (shepherd-service-back-edges services)
|
(define (shepherd-service-back-edges services)
|
||||||
"Return a procedure that, when given a <shepherd-service> from SERVICES,
|
"Return a procedure that, when given a <shepherd-service> from SERVICES,
|
||||||
returns the list of <shepherd-service> that depend on it."
|
returns the list of <shepherd-service> that depend on it."
|
||||||
(define provision->service
|
(define provision->service
|
||||||
(let ((services (fold (lambda (service result)
|
(shepherd-service-lookup-procedure services))
|
||||||
(fold (cut vhash-consq <> service <>)
|
|
||||||
result
|
|
||||||
(shepherd-service-provision service)))
|
|
||||||
vlist-null
|
|
||||||
services)))
|
|
||||||
(lambda (name)
|
|
||||||
(match (vhash-assq name services)
|
|
||||||
((_ . service) service)
|
|
||||||
(#f #f)))))
|
|
||||||
|
|
||||||
(define edges
|
(define edges
|
||||||
(fold (lambda (service edges)
|
(fold (lambda (service edges)
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -105,6 +105,15 @@
|
||||||
(fold-services (list s) #:target-type t1)
|
(fold-services (list s) #:target-type t1)
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
|
(test-assert "shepherd-service-lookup-procedure"
|
||||||
|
(let* ((s1 (shepherd-service (provision '(s1 s1b)) (start #f)))
|
||||||
|
(s2 (shepherd-service (provision '(s2 s2b)) (start #f)))
|
||||||
|
(s3 (shepherd-service (provision '(s3 s3b s3c)) (start #f)))
|
||||||
|
(lookup (shepherd-service-lookup-procedure (list s1 s2 s3))))
|
||||||
|
(and (eq? (lookup 's1) (lookup 's1b) s1)
|
||||||
|
(eq? (lookup 's2) (lookup 's2b) s2)
|
||||||
|
(eq? (lookup 's3) (lookup 's3b) s3))))
|
||||||
|
|
||||||
(test-assert "shepherd-service-back-edges"
|
(test-assert "shepherd-service-back-edges"
|
||||||
(let* ((s1 (shepherd-service (provision '(s1)) (start #f)))
|
(let* ((s1 (shepherd-service (provision '(s1)) (start #f)))
|
||||||
(s2 (shepherd-service (provision '(s2))
|
(s2 (shepherd-service (provision '(s2))
|
||||||
|
|
Loading…
Reference in New Issue