Merge branch 'master' into dbus-update

3 files changed, 70 insertions, 25 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index adafe1b55e..336cc4dec9 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -125,7 +125,8 @@
    (respawn? #f)))
 
 (define root-file-system-service-type
-  (dmd-service-type (const %root-file-system-dmd-service)))
+  (dmd-service-type 'root-file-system
+                    (const %root-file-system-dmd-service)))
 
 (define (root-file-system-service)
   "Return a service whose sole purpose is to re-mount read-only the root file
@@ -145,6 +146,7 @@ FILE-SYSTEM."
   ;; TODO(?): Make this an extensible service that takes <file-system> objects
   ;; and returns a list of <dmd-service>.
   (dmd-service-type
+   'file-system
    (lambda (file-system)
      (let ((target  (file-system-mount-point file-system))
            (device  (file-system-device file-system))
@@ -205,10 +207,11 @@ object."
 
 (define user-unmount-service-type
   (dmd-service-type
+   'user-file-systems
    (lambda (known-mount-points)
      (dmd-service
       (documentation "Unmount manually-mounted file systems.")
-      (provision '(user-unmount))
+      (provision '(user-file-systems))
       (start #~(const #t))
       (stop #~(lambda args
                 (define (known? mount-point)
@@ -242,14 +245,15 @@ in KNOWN-MOUNT-POINTS when it is stopped."
 
 (define user-processes-service-type
   (dmd-service-type
+   'user-processes
    (match-lambda
      ((requirements grace-delay)
       (dmd-service
        (documentation "When stopped, terminate all user processes.")
        (provision '(user-processes))
-       (requirement (cons 'root-file-system
-                          (map file-system->dmd-service-name
-                               requirements)))
+       (requirement (cons* 'root-file-system 'user-file-systems
+                           (map file-system->dmd-service-name
+                                requirements)))
        (start #~(const #t))
        (stop #~(lambda _
                  (define (kill-except omit signal)
@@ -337,6 +341,7 @@ stopped before 'kill' is called."
 
 (define host-name-service-type
   (dmd-service-type
+   'host-name
    (lambda (name)
      (dmd-service
       (documentation "Initialize the machine's host name.")
@@ -369,6 +374,7 @@ stopped before 'kill' is called."
 
 (define console-keymap-service-type
   (dmd-service-type
+   'console-keymap
    (lambda (file)
      (dmd-service
       (documentation (string-append "Load console keymap (loadkeys)."))
@@ -384,6 +390,7 @@ stopped before 'kill' is called."
 
 (define console-font-service-type
   (dmd-service-type
+   'console-font
    (match-lambda
      ((tty font)
       (let ((device (string-append "/dev/" tty)))
@@ -644,6 +651,7 @@ Service Switch}, for an example."
 
 (define syslog-service-type
   (dmd-service-type
+   'syslog
    (lambda (config-file)
      (dmd-service
       (documentation "Run the syslog daemon (syslogd).")
@@ -982,6 +990,7 @@ extra rules from the packages listed in @var{rules}."
 
 (define device-mapping-service-type
   (dmd-service-type
+   'device-mapping
    (match-lambda
      ((target open close)
       (dmd-service
@@ -1001,6 +1010,7 @@ gexp, to open it, and evaluate @var{close} to close it."
 
 (define swap-service-type
   (dmd-service-type
+   'swap
    (lambda (device)
      (define requirement
        (if (string-prefix? "/dev/mapper/" device)
diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index 6020ffc8eb..e87b9e4415 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -27,7 +27,9 @@
   #:use-module (gnu services)
   #:use-module (gnu packages admin)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (dmd-root-service-type
@@ -42,7 +44,9 @@
             dmd-service-respawn?
             dmd-service-start
             dmd-service-stop
-            dmd-service-auto-start?))
+            dmd-service-auto-start?
+
+            dmd-service-back-edges))
 
 ;;; Commentary:
 ;;;
@@ -86,11 +90,11 @@
   ;; <dmd-service> objects.
   (service dmd-root-service-type '()))
 
-(define-syntax-rule (dmd-service-type proc)
+(define-syntax-rule (dmd-service-type service-name proc)
   "Return a <service-type> denoting a simple dmd service--i.e., the type for a
 service that extends DMD-ROOT-SERVICE-TYPE and nothing else."
   (service-type
-   (name 'some-dmd-service)
+   (name service-name)
    (extensions
     (list (service-extension dmd-root-service-type
                              (compose list proc))))))
@@ -98,17 +102,17 @@ service that extends DMD-ROOT-SERVICE-TYPE and nothing else."
 (define-record-type* <dmd-service>
   dmd-service make-dmd-service
   dmd-service?
-  (documentation service-documentation            ; string
+  (documentation dmd-service-documentation        ;string
                  (default "[No documentation.]"))
-  (provision     service-provision)               ; list of symbols
-  (requirement   service-requirement              ; list of symbols
+  (provision     dmd-service-provision)           ;list of symbols
+  (requirement   dmd-service-requirement          ;list of symbols
                  (default '()))
-  (respawn?      service-respawn?                 ; Boolean
+  (respawn?      dmd-service-respawn?             ;Boolean
                  (default #t))
-  (start         service-start)                   ; g-expression (procedure)
-  (stop          service-stop                     ; g-expression (procedure)
+  (start         dmd-service-start)               ;g-expression (procedure)
+  (stop          dmd-service-stop                 ;g-expression (procedure)
                  (default #~(const #f)))
-  (auto-start?   service-auto-start?              ; Boolean
+  (auto-start?   dmd-service-auto-start?          ;Boolean
                  (default #t)))
 
 
@@ -127,8 +131,8 @@ failure."
                         (format #f (_ "service '~a' provided more than once")
                                 symbol)))))))
 
-          (for-each assert-unique (service-provision service))
-          (fold set-insert set (service-provision service)))
+          (for-each assert-unique (dmd-service-provision service))
+          (fold set-insert set (dmd-service-provision service)))
         (setq)
         services))
 
@@ -160,12 +164,12 @@ failure."
           (register-services
            #$@(map (lambda (service)
                      #~(make <service>
-                         #:docstring '#$(service-documentation service)
-                         #:provides '#$(service-provision service)
-                         #:requires '#$(service-requirement service)
-                         #:respawn? '#$(service-respawn? service)
-                         #:start #$(service-start service)
-                         #:stop #$(service-stop service)))
+                         #:docstring '#$(dmd-service-documentation service)
+                         #:provides '#$(dmd-service-provision service)
+                         #:requires '#$(dmd-service-requirement service)
+                         #:respawn? '#$(dmd-service-respawn? service)
+                         #:start #$(dmd-service-start service)
+                         #:stop #$(dmd-service-stop service)))
                    services))
 
           ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it.
@@ -173,9 +177,38 @@ failure."
 
           (format #t "starting services...~%")
           (for-each start
-                    '#$(append-map service-provision
-                                   (filter service-auto-start? services)))))
+                    '#$(append-map dmd-service-provision
+                                   (filter dmd-service-auto-start?
+                                           services)))))
 
     (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
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 52a843b54b..003d5a5010 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -94,6 +94,7 @@ fe80::1%lo0 apps.facebook.com\n")
 
 (define static-networking-service-type
   (dmd-service-type
+   'static-networking
    (match-lambda
      (($ <static-networking> interface ip gateway provision
                              name-servers net-tools)
@@ -166,6 +167,7 @@ gateway."
 
 (define dhcp-client-service-type
   (dmd-service-type
+   'dhcp-client
    (lambda (dhcp)
      (define dhclient
        #~(string-append #$dhcp "/sbin/dhclient"))