mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
services: Add 'dmd-service-back-edges'.
* gnu/services/dmd.scm (dmd-service-back-edges): New procedure. * tests/services.scm ("dmd-service-back-edges"): New test.
This commit is contained in:
parent
c5d735f798
commit
80a6773483
2 changed files with 43 additions and 1 deletions
|
@ -27,7 +27,9 @@ (define-module (gnu services dmd)
|
||||||
#:use-module (gnu services)
|
#:use-module (gnu services)
|
||||||
#:use-module (gnu packages admin)
|
#:use-module (gnu packages admin)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 vlist)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
#:export (dmd-root-service-type
|
#:export (dmd-root-service-type
|
||||||
|
@ -42,7 +44,9 @@ (define-module (gnu services dmd)
|
||||||
dmd-service-respawn?
|
dmd-service-respawn?
|
||||||
dmd-service-start
|
dmd-service-start
|
||||||
dmd-service-stop
|
dmd-service-stop
|
||||||
dmd-service-auto-start?))
|
dmd-service-auto-start?
|
||||||
|
|
||||||
|
dmd-service-back-edges))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
@ -179,4 +183,32 @@ (define config
|
||||||
|
|
||||||
(gexp->file "dmd.conf" config)))
|
(gexp->file "dmd.conf" config)))
|
||||||
|
|
||||||
|
(define (dmd-service-back-edges services)
|
||||||
|
"Return a procedure that, when given a <dmd-service> from SERVICES, returns
|
||||||
|
the list of <dmd-service> that depend on it."
|
||||||
|
(define provision->service
|
||||||
|
(let ((services (fold (lambda (service result)
|
||||||
|
(fold (cut vhash-consq <> service <>)
|
||||||
|
result
|
||||||
|
(dmd-service-provision service)))
|
||||||
|
vlist-null
|
||||||
|
services)))
|
||||||
|
(lambda (name)
|
||||||
|
(match (vhash-assq name services)
|
||||||
|
((_ . service) service)
|
||||||
|
(#f #f)))))
|
||||||
|
|
||||||
|
(define edges
|
||||||
|
(fold (lambda (service edges)
|
||||||
|
(fold (lambda (requirement edges)
|
||||||
|
(vhash-consq (provision->service requirement) service
|
||||||
|
edges))
|
||||||
|
edges
|
||||||
|
(dmd-service-requirement service)))
|
||||||
|
vlist-null
|
||||||
|
services))
|
||||||
|
|
||||||
|
(lambda (service)
|
||||||
|
(vhash-foldq* cons '() service edges)))
|
||||||
|
|
||||||
;;; dmd.scm ends here
|
;;; dmd.scm ends here
|
||||||
|
|
|
@ -18,6 +18,7 @@
|
||||||
|
|
||||||
(define-module (test-services)
|
(define-module (test-services)
|
||||||
#:use-module (gnu services)
|
#:use-module (gnu services)
|
||||||
|
#:use-module (gnu services dmd)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
|
@ -104,6 +105,15 @@ (define-module (test-services)
|
||||||
(fold-services (list s) #:target-type t1)
|
(fold-services (list s) #:target-type t1)
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
|
(test-assert "dmd-service-back-edges"
|
||||||
|
(let* ((s1 (dmd-service (provision '(s1)) (start #f)))
|
||||||
|
(s2 (dmd-service (provision '(s2)) (requirement '(s1)) (start #f)))
|
||||||
|
(s3 (dmd-service (provision '(s3)) (requirement '(s1 s2)) (start #f)))
|
||||||
|
(e (dmd-service-back-edges (list s1 s2 s3))))
|
||||||
|
(and (lset= eq? (e s1) (list s2 s3))
|
||||||
|
(lset= eq? (e s2) (list s3))
|
||||||
|
(null? (e s3)))))
|
||||||
|
|
||||||
(test-end)
|
(test-end)
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue