From 00184239c34694ba3005bccde498ae5962c06758 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 14 Oct 2015 15:09:18 +0200 Subject: services: 'dmd-service-type' takes a service name. * gnu/services/dmd.scm (dmd-service-type): Add 'service-name' parameter. * gnu/services/base.scm, gnu/services/networking.scm, gnu/system/install.scm: Adjust callers. --- gnu/services/base.scm | 12 +++++++++++- gnu/services/dmd.scm | 4 ++-- gnu/services/networking.scm | 2 ++ 3 files changed, 15 insertions(+), 3 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index adafe1b55e..84869ae31b 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 objects ;; and returns a list of . (dmd-service-type + 'file-system (lambda (file-system) (let ((target (file-system-mount-point file-system)) (device (file-system-device file-system)) @@ -205,6 +207,7 @@ object." (define user-unmount-service-type (dmd-service-type + 'user-unmount (lambda (known-mount-points) (dmd-service (documentation "Unmount manually-mounted file systems.") @@ -242,6 +245,7 @@ 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 @@ -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..418511b289 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -86,11 +86,11 @@ ;; objects. (service dmd-root-service-type '())) -(define-syntax-rule (dmd-service-type proc) +(define-syntax-rule (dmd-service-type service-name proc) "Return a 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)))))) 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 (($ 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")) -- cgit v1.2.3 From c5d735f798e0e58774b9ce0c6197695bc6f0daa9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 14 Oct 2015 18:38:46 +0200 Subject: services: Prefix accessors with 'dmd-'. * gnu/services/dmd.scm (): Prefix accessor identifiers with 'dmd-', as was intended. Update users accordingly. --- gnu/services/dmd.scm | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 418511b289..7b6434a0ae 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -98,17 +98,17 @@ service that extends DMD-ROOT-SERVICE-TYPE and nothing else." (define-record-type* 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 +127,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 +160,12 @@ failure." (register-services #$@(map (lambda (service) #~(make - #: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,8 +173,9 @@ 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))) -- cgit v1.2.3 From 80a67734834a0981ca65cf1757a7d8408d02f1fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 14 Oct 2015 18:40:33 +0200 Subject: 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. --- gnu/services/dmd.scm | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 7b6434a0ae..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: ;;; @@ -179,4 +183,32 @@ failure." (gexp->file "dmd.conf" config))) +(define (dmd-service-back-edges services) + "Return a procedure that, when given a from SERVICES, returns +the list of 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 -- cgit v1.2.3 From 5f44ee4fa02699effed459266ff00a958bfd788e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 14 Oct 2015 21:16:55 +0200 Subject: services: Unmount user file systems after process termination. * gnu/services/base.scm (user-unmount-service-type): Change label and dmd name to 'user-file-systems'. (user-processes-service-type)[requirement]: Add 'user-file-systems'. --- gnu/services/base.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 84869ae31b..336cc4dec9 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -207,11 +207,11 @@ object." (define user-unmount-service-type (dmd-service-type - 'user-unmount + '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) @@ -251,9 +251,9 @@ in KNOWN-MOUNT-POINTS when it is stopped." (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) -- cgit v1.2.3