summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-08-31 12:38:38 +0200
committerLudovic Courtès <ludo@gnu.org>2016-08-31 15:44:20 +0200
commita5d78eb64bcb87440a0b3ff25eec5568df0bc47c (patch)
tree0e358fc5568bfd4ac5577c91de3eaca235aacbf1
parentb8692e4696d0d2b36466827da1e0d25d69a298af (diff)
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.scm30
-rw-r--r--tests/services.scm11
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))