diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2016-08-31 12:38:38 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2016-08-31 15:44:20 +0200 |
| commit | a5d78eb64bcb87440a0b3ff25eec5568df0bc47c (patch) | |
| tree | 0e358fc5568bfd4ac5577c91de3eaca235aacbf1 | |
| parent | b8692e4696d0d2b36466827da1e0d25d69a298af (diff) | |
| download | guix-a5d78eb64bcb87440a0b3ff25eec5568df0bc47c.tar guix-a5d78eb64bcb87440a0b3ff25eec5568df0bc47c.tar.gz | |
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.
| -rw-r--r-- | gnu/services/shepherd.scm | 30 | ||||
| -rw-r--r-- | tests/services.scm | 11 |
2 files changed, 30 insertions, 11 deletions
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index a14f51592a..3cfca8574e 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -52,6 +52,7 @@ shepherd-service-file + shepherd-service-lookup-procedure shepherd-service-back-edges)) ;;; Commentary: @@ -249,20 +250,29 @@ stored." (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) "Return a procedure that, when given a <shepherd-service> from SERVICES, returns the list of <shepherd-service> that depend on it." (define provision->service - (let ((services (fold (lambda (service result) - (fold (cut vhash-consq <> service <>) - result - (shepherd-service-provision service))) - vlist-null - services))) - (lambda (name) - (match (vhash-assq name services) - ((_ . service) service) - (#f #f))))) + (shepherd-service-lookup-procedure services)) (define edges (fold (lambda (service edges) diff --git a/tests/services.scm b/tests/services.scm index 477a197160..12745c8006 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -1,5 +1,5 @@ ;;; 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. ;;; @@ -105,6 +105,15 @@ (fold-services (list s) #:target-type t1) #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" (let* ((s1 (shepherd-service (provision '(s1)) (start #f))) (s2 (shepherd-service (provision '(s2)) |