nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

services: Rename 'dmd' services to 'shepherd'. 

* gnu/services/shepherd.scm (dmd-root-service-type, %dmd-root-service)
  (dmd-service-type, <dmd-service>, dmd-service, dmd-service?)
  (make-dmd-service, dmd-service-documentation, dmd-service-provision)
  (dmd-service-requirement, dmd-service-respawn, dmd-service-start)
  (dmd-service-stop, dmd-service-auto-start?, dmd-service-modules)
  (dmd-service-imported-modules, dmd-service-file-name, dmd-service-file)
  (dmd-service-back-edges): Rename to...
  (shepherd-root-service-type, %shepherd-root-service, shepherd-service-type)
  (<shepherd-service>, shepherd-service, shepherd-service?)
  (make-shepherd-service, shepherd-service-documentation)
  (shepherd-service-provision, shepherd-service-requirement)
  (shepherd-service-respawn, shepherd-service-start)
  (shepherd-service-stop, shepherd-service-auto-start?)
  (shepherd-service-modules, shepherd-service-imported-modules)
  (shepherd-service-file-name, shepherd-service-file)
  (shepherd-service-back-edges): ...this
* gnu/services.scm: Adjust comments.
* gnu/services/avahi.scm (avahi-dmd-service): Rename to...
  (avahi-shepherd-service): ... this.
* gnu/services/base.scm (%root-file-system-dmd-service)
  (file-system->dmd-service-name, mapped-device->dmd-service-name)
  (dependency->dmd-service-name, file-system-dmd-service)
  (mingetty-dmd-service, nscd-dmd-service, guix-dmd-service)
  (guix-publish-dmd-service, udev-dmd-service, gpm-dmd-service): Rename to...
  (%root-file-system-shepherd-service)
  (file-system->shepherd-service-name, mapped-device->shepherd-service-name)
  (dependency->shepherd-service-name, file-system-shepherd-service)
  (mingetty-shepherd-service, nscd-shepherd-service, guix-shepherd-service)
  (guix-publish-shepherd-service, udev-shepherd-service)
  (gpm-shepherd-service): ... this.
* gnu/services/databases.scm (postgresql-dmd-service): Rename to...
  (postgresql-shepherd-service): ... this.
* gnu/services/desktop.scm (upower-dmd-service, elogind-dmd-service):
  Rename to...
  (upower-shepherd-service, elogind-shepherd-service): ... this.
* gnu/services/dbus.scm (dbus-dmd-service): Rename to...
  (dbus-shepherd-service): ... this.
* gnu/services/lirc.scm (lirc-dmd-service): Rename to...
  (lirc-shepherd-service): ... this.
* gnu/services/mail.scm (dovecot-dmd-service): Rename to...
  (dovecot-shepherd-service): ... this.
* gnu/services/networking.scm (ntp-dmd-service, tor-dmd-service)
  (bitlbee-dmd-service, wicd-dmd-service, network-manager-dmd-service): Rename to...
  (dbus-shepherd-service): ... this.
* gnu/services/ssh.scm (lsh-dmd-service): Rename to...
  (lsh-shepherd-service): ... this.
* gnu/services/web.scm (nginx-dmd-service): Rename to...
  (nginx-shepherd-service): ... this.
* gnu/services/xorg.scm (slim-dmd-service): Rename to...
  (slim-shepherd-service): ... this.
* gnu/system.scm (essential-services): Use '%shepherd-root-service'.
* gnu/system/install.scm (cow-store-service-type): Adjust accordingly.
* guix/scripts/system.scm (dmd-service-node-label, dmd-service-node-type)
  (export-dmd-graph): Likewise.
* tests/guix-system.sh: Likewise.
* tests/services.scm ("dmd-service-back-edges"): Rename to...
  ("shepherd-service-back-edges"): Adjust accordingly.
* doc/guix.texi: Likewise.
* doc/images/service-graph.dot: Use 'shepherd' service name.
This commit is contained in:
Alex Kost 2016-01-27 23:02:31 +03:00
parent 26b94866ad
commit d4053c710b
20 changed files with 266 additions and 259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
doc/guix.texi
View File

@ -9491,7 +9491,7 @@ with a simple example, the service type for the Guix build daemon
(service-type (service-type
(name 'guix) (name 'guix)
(extensions (extensions
(list (service-extension dmd-root-service-type guix-dmd-service) (list (service-extension shepherd-root-service-type guix-shepherd-service)
(service-extension account-service-type guix-accounts) (service-extension account-service-type guix-accounts)
(service-extension activation-service-type guix-activation))))) (service-extension activation-service-type guix-activation)))))
@end example @end example
@ -9515,11 +9515,11 @@ exception is the @dfn{boot service type}, which is the ultimate service.
In this example, @var{guix-service-type} extends three services: In this example, @var{guix-service-type} extends three services:
@table @var @table @var
@item dmd-root-service-type @item shepherd-root-service-type
The @var{guix-dmd-service} procedure defines how the Shepherd service is The @var{guix-shepherd-service} procedure defines how the Shepherd
extended. Namely, it returns a @code{<dmd-service>} object that defines service is extended. Namely, it returns a @code{<shepherd-service>}
how @command{guix-daemon} is started and stopped (@pxref{Shepherd object that defines how @command{guix-daemon} is started and stopped
Services}). (@pxref{Shepherd Services}).
@item account-service-type @item account-service-type
This extension for this service is computed by @var{guix-accounts}, This extension for this service is computed by @var{guix-accounts},
@ -9558,8 +9558,8 @@ The service type for an @emph{extensible} service looks like this:
(define udev-service-type (define udev-service-type
(service-type (name 'udev) (service-type (name 'udev)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
udev-dmd-service))) udev-shepherd-service)))
(compose concatenate) ;concatenate the list of rules (compose concatenate) ;concatenate the list of rules
(extend (lambda (config rules) (extend (lambda (config rules)
@ -9573,7 +9573,7 @@ The service type for an @emph{extensible} service looks like this:
This is the service type for the This is the service type for the
@uref{https://wiki.gentoo.org/wiki/Project:Eudev, eudev device @uref{https://wiki.gentoo.org/wiki/Project:Eudev, eudev device
management daemon}. Compared to the previous example, in addition to an management daemon}. Compared to the previous example, in addition to an
extension of @var{dmd-root-service-type}, we see two new fields: extension of @var{shepherd-root-service-type}, we see two new fields:
@table @code @table @code
@item compose @item compose
@ -9801,11 +9801,11 @@ You can actually generate such a graph for any operating system
definition using the @command{guix system dmd-graph} command definition using the @command{guix system dmd-graph} command
(@pxref{system-dmd-graph, @command{guix system dmd-graph}}). (@pxref{system-dmd-graph, @command{guix system dmd-graph}}).
The @var{%dmd-root-service} is a service object representing PID@tie{}1, The @var{%shepherd-root-service} is a service object representing
of type @var{dmd-root-service-type}; it can be extended by passing it PID@tie{}1, of type @var{shepherd-root-service-type}; it can be extended
lists of @code{<dmd-service>} objects. by passing it lists of @code{<shepherd-service>} objects.
@deftp {Data Type} dmd-service @deftp {Data Type} shepherd-service
The data type representing a service managed by the Shepherd. The data type representing a service managed by the Shepherd.
@table @asis @table @asis
@ -9853,15 +9853,15 @@ the Shepherd.
@end table @end table
@end deftp @end deftp
@defvr {Scheme Variable} dmd-root-service-type @defvr {Scheme Variable} shepherd-root-service-type
The service type for the Shepherd ``root service''---i.e., PID@tie{}1. The service type for the Shepherd ``root service''---i.e., PID@tie{}1.
This is the service type that extensions target when they want to create This is the service type that extensions target when they want to create
shepherd services (@pxref{Service Types and Services}, for an example). shepherd services (@pxref{Service Types and Services}, for an example).
Each extension must pass a list of @code{<dmd-service>}. Each extension must pass a list of @code{<shepherd-service>}.
@end defvr @end defvr
@defvr {Scheme Variable} %dmd-root-service @defvr {Scheme Variable} %shepherd-root-service
This service represents PID@tie{}1. This service represents PID@tie{}1.
@end defvr @end defvr

14
doc/images/service-graph.dot
View File

@ -1,5 +1,5 @@
digraph "Service Type Dependencies" { digraph "Service Type Dependencies" {
dmd [shape = box, fontname = Helvetica]; shepherd [shape = box, fontname = Helvetica];
pam [shape = box, fontname = Helvetica]; pam [shape = box, fontname = Helvetica];
etc [shape = box, fontname = Helvetica]; etc [shape = box, fontname = Helvetica];
profile [shape = box, fontname = Helvetica]; profile [shape = box, fontname = Helvetica];
@ -7,14 +7,14 @@ digraph "Service Type Dependencies" {
activation [shape = box, fontname = Helvetica]; activation [shape = box, fontname = Helvetica];
boot [shape = box, fontname = Helvetica]; boot [shape = box, fontname = Helvetica];
system [shape = house, fontname = Helvetica]; system [shape = house, fontname = Helvetica];
lshd -> dmd; lshd -> shepherd;
lshd -> pam; lshd -> pam;
udev -> dmd; udev -> shepherd;
nscd -> dmd [label = "extends"]; nscd -> shepherd [label = "extends"];
"nss-mdns" -> nscd; "nss-mdns" -> nscd;
"kvm-rules" -> udev; "kvm-rules" -> udev;
colord -> udev; colord -> udev;
dbus -> dmd; dbus -> shepherd;
colord -> dbus; colord -> dbus;
upower -> udev; upower -> udev;
upower -> dbus; upower -> dbus;
@ -23,7 +23,7 @@ digraph "Service Type Dependencies" {
elogind -> dbus; elogind -> dbus;
elogind -> udev; elogind -> udev;
elogind -> polkit [label = "extends"]; elogind -> polkit [label = "extends"];
dmd -> boot; shepherd -> boot;
colord -> accounts; colord -> accounts;
accounts -> activation; accounts -> activation;
accounts -> etc; accounts -> etc;
@ -31,7 +31,7 @@ digraph "Service Type Dependencies" {
activation -> boot; activation -> boot;
pam -> etc; pam -> etc;
elogind -> pam; elogind -> pam;
guix -> dmd; guix -> shepherd;
guix -> activation; guix -> activation;
guix -> accounts; guix -> accounts;
boot -> system; boot -> system;

6
gnu/services.scm
View File

@ -86,8 +86,8 @@
;;; A service type describe how its instances extend instances of other ;;; A service type describe how its instances extend instances of other
;;; service types. For instance, some services extend the instance of ;;; service types. For instance, some services extend the instance of
;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create; ;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
;;; others extend DMD-ROOT-SERVICE-TYPE by passing it instances of ;;; others extend SHEPHERD-ROOT-SERVICE-TYPE by passing it instances of
;;; <dmd-service>. ;;; <shepherd-service>.
;;; ;;;
;;; When applicable, the service type defines how it can itself be extended, ;;; When applicable, the service type defines how it can itself be extended,
;;; by providing one procedure to compose extensions, and one procedure to ;;; by providing one procedure to compose extensions, and one procedure to
@ -209,7 +209,7 @@ containing the given entries."
(define (compute-boot-script _ mexps) (define (compute-boot-script _ mexps)
(mlet %store-monad ((gexps (sequence %store-monad mexps))) (mlet %store-monad ((gexps (sequence %store-monad mexps)))
(gexp->file "boot" (gexp->file "boot"
;; Clean up and activate the system, then spawn dmd. ;; Clean up and activate the system, then spawn shepherd.
#~(begin #$@gexps)))) #~(begin #$@gexps))))
(define (boot-script-entry mboot) (define (boot-script-entry mboot)

10
gnu/services/avahi.scm
View File

@ -93,11 +93,11 @@
(use-modules (guix build utils)) (use-modules (guix build utils))
(mkdir-p "/var/run/avahi-daemon"))) (mkdir-p "/var/run/avahi-daemon")))
(define (avahi-dmd-service config) (define (avahi-shepherd-service config)
"Return a list of <dmd-service> for CONFIG." "Return a list of <shepherd-service> for CONFIG."
(let ((config (configuration-file config)) (let ((config (configuration-file config))
(avahi (avahi-configuration-avahi config))) (avahi (avahi-configuration-avahi config)))
(list (dmd-service (list (shepherd-service
(documentation "Run the Avahi mDNS/DNS-SD responder.") (documentation "Run the Avahi mDNS/DNS-SD responder.")
(provision '(avahi-daemon)) (provision '(avahi-daemon))
(requirement '(dbus-system networking)) (requirement '(dbus-system networking))
@ -111,8 +111,8 @@
(let ((avahi-package (compose list avahi-configuration-avahi))) (let ((avahi-package (compose list avahi-configuration-avahi)))
(service-type (name 'avahi) (service-type (name 'avahi)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
avahi-dmd-service) avahi-shepherd-service)
(service-extension dbus-root-service-type (service-extension dbus-root-service-type
avahi-package) avahi-package)
(service-extension account-service-type (service-extension account-service-type

126
gnu/services/base.scm
View File

@ -148,8 +148,8 @@
(compose identity) (compose identity)
(extend append))) (extend append)))
(define %root-file-system-dmd-service (define %root-file-system-shepherd-service
(dmd-service (shepherd-service
(documentation "Take care of the root file system.") (documentation "Take care of the root file system.")
(provision '(root-file-system)) (provision '(root-file-system))
(start #~(const #t)) (start #~(const #t))
@ -181,37 +181,37 @@
(respawn? #f))) (respawn? #f)))
(define root-file-system-service-type (define root-file-system-service-type
(dmd-service-type 'root-file-system (shepherd-service-type 'root-file-system
(const %root-file-system-dmd-service))) (const %root-file-system-shepherd-service)))
(define (root-file-system-service) (define (root-file-system-service)
"Return a service whose sole purpose is to re-mount read-only the root file "Return a service whose sole purpose is to re-mount read-only the root file
system upon shutdown (aka. cleanly \"umounting\" root.) system upon shutdown (aka. cleanly \"umounting\" root.)
This service must be the root of the service dependency graph so that its This service must be the root of the service dependency graph so that its
'stop' action is invoked when dmd is the only process left." 'stop' action is invoked when shepherd is the only process left."
(service root-file-system-service-type #f)) (service root-file-system-service-type #f))
(define (file-system->dmd-service-name file-system) (define (file-system->shepherd-service-name file-system)
"Return the symbol that denotes the service mounting and unmounting "Return the symbol that denotes the service mounting and unmounting
FILE-SYSTEM." FILE-SYSTEM."
(symbol-append 'file-system- (symbol-append 'file-system-
(string->symbol (file-system-mount-point file-system)))) (string->symbol (file-system-mount-point file-system))))
(define (mapped-device->dmd-service-name md) (define (mapped-device->shepherd-service-name md)
"Return the symbol that denotes the dmd service of MD, a <mapped-device>." "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
(symbol-append 'device-mapping- (symbol-append 'device-mapping-
(string->symbol (mapped-device-target md)))) (string->symbol (mapped-device-target md))))
(define dependency->dmd-service-name (define dependency->shepherd-service-name
(match-lambda (match-lambda
((? mapped-device? md) ((? mapped-device? md)
(mapped-device->dmd-service-name md)) (mapped-device->shepherd-service-name md))
((? file-system? fs) ((? file-system? fs)
(file-system->dmd-service-name fs)))) (file-system->shepherd-service-name fs))))
(define (file-system-dmd-service file-system) (define (file-system-shepherd-service file-system)
"Return a list containing the dmd service for @var{file-system}." "Return a list containing the shepherd service for @var{file-system}."
(let ((target (file-system-mount-point file-system)) (let ((target (file-system-mount-point file-system))
(device (file-system-device file-system)) (device (file-system-device file-system))
(type (file-system-type file-system)) (type (file-system-type file-system))
@ -221,10 +221,10 @@ FILE-SYSTEM."
(dependencies (file-system-dependencies file-system))) (dependencies (file-system-dependencies file-system)))
(if (file-system-mount? file-system) (if (file-system-mount? file-system)
(list (list
(dmd-service (shepherd-service
(provision (list (file-system->dmd-service-name file-system))) (provision (list (file-system->shepherd-service-name file-system)))
(requirement `(root-file-system (requirement `(root-file-system
,@(map dependency->dmd-service-name dependencies))) ,@(map dependency->shepherd-service-name dependencies)))
(documentation "Check, mount, and unmount the given file system.") (documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args (start #~(lambda args
;; FIXME: Use or factorize with 'mount-file-system'. ;; FIXME: Use or factorize with 'mount-file-system'.
@ -276,11 +276,11 @@ FILE-SYSTEM."
(define file-system-service-type (define file-system-service-type
;; TODO(?): Make this an extensible service that takes <file-system> objects ;; TODO(?): Make this an extensible service that takes <file-system> objects
;; and returns a list of <dmd-service>. ;; and returns a list of <shepherd-service>.
(service-type (name 'file-system) (service-type (name 'file-system)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
file-system-dmd-service) file-system-shepherd-service)
(service-extension fstab-service-type (service-extension fstab-service-type
identity))))) identity)))))
@ -290,10 +290,10 @@ object."
(service file-system-service-type file-system)) (service file-system-service-type file-system))
(define user-unmount-service-type (define user-unmount-service-type
(dmd-service-type (shepherd-service-type
'user-file-systems 'user-file-systems
(lambda (known-mount-points) (lambda (known-mount-points)
(dmd-service (shepherd-service
(documentation "Unmount manually-mounted file systems.") (documentation "Unmount manually-mounted file systems.")
(provision '(user-file-systems)) (provision '(user-file-systems))
(start #~(const #t)) (start #~(const #t))
@ -328,15 +328,15 @@ in KNOWN-MOUNT-POINTS when it is stopped."
"/etc/shepherd/do-not-kill") "/etc/shepherd/do-not-kill")
(define user-processes-service-type (define user-processes-service-type
(dmd-service-type (shepherd-service-type
'user-processes 'user-processes
(match-lambda (match-lambda
((requirements grace-delay) ((requirements grace-delay)
(dmd-service (shepherd-service
(documentation "When stopped, terminate all user processes.") (documentation "When stopped, terminate all user processes.")
(provision '(user-processes)) (provision '(user-processes))
(requirement (cons* 'root-file-system 'user-file-systems (requirement (cons* 'root-file-system 'user-file-systems
(map file-system->dmd-service-name (map file-system->shepherd-service-name
requirements))) requirements)))
(start #~(const #t)) (start #~(const #t))
(stop #~(lambda _ (stop #~(lambda _
@ -410,7 +410,7 @@ that the root file system can be re-mounted read-only, just before
rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
has been sent are terminated with SIGKILL. has been sent are terminated with SIGKILL.
The returned service will depend on 'root-file-system' and on all the dmd The returned service will depend on 'root-file-system' and on all the shepherd
services corresponding to FILE-SYSTEMS. services corresponding to FILE-SYSTEMS.
All the services that spawn processes must depend on this one so that they are All the services that spawn processes must depend on this one so that they are
@ -457,10 +457,10 @@ strings or string-valued gexps."
;;; ;;;
(define host-name-service-type (define host-name-service-type
(dmd-service-type (shepherd-service-type
'host-name 'host-name
(lambda (name) (lambda (name)
(dmd-service (shepherd-service
(documentation "Initialize the machine's host name.") (documentation "Initialize the machine's host name.")
(provision '(host-name)) (provision '(host-name))
(start #~(lambda _ (start #~(lambda _
@ -490,10 +490,10 @@ strings or string-valued gexps."
(zero? (cdr (waitpid pid)))))))) (zero? (cdr (waitpid pid))))))))
(define console-keymap-service-type (define console-keymap-service-type
(dmd-service-type (shepherd-service-type
'console-keymap 'console-keymap
(lambda (file) (lambda (file)
(dmd-service (shepherd-service
(documentation (string-append "Load console keymap (loadkeys).")) (documentation (string-append "Load console keymap (loadkeys)."))
(provision '(console-keymap)) (provision '(console-keymap))
(start #~(lambda _ (start #~(lambda _
@ -506,12 +506,12 @@ strings or string-valued gexps."
(service console-keymap-service-type file)) (service console-keymap-service-type file))
(define console-font-service-type (define console-font-service-type
(dmd-service-type (shepherd-service-type
'console-font 'console-font
(match-lambda (match-lambda
((tty font) ((tty font)
(let ((device (string-append "/dev/" tty))) (let ((device (string-append "/dev/" tty)))
(dmd-service (shepherd-service
(documentation "Load a Unicode console font.") (documentation "Load a Unicode console font.")
(provision (list (symbol-append 'console-font- (provision (list (symbol-append 'console-font-
(string->symbol tty)))) (string->symbol tty))))
@ -568,12 +568,12 @@ strings or string-valued gexps."
#:motd #:motd
(mingetty-configuration-motd conf)))) (mingetty-configuration-motd conf))))
(define mingetty-dmd-service (define mingetty-shepherd-service
(match-lambda (match-lambda
(($ <mingetty-configuration> mingetty tty motd auto-login login-program (($ <mingetty-configuration> mingetty tty motd auto-login login-program
login-pause? allow-empty-passwords?) login-pause? allow-empty-passwords?)
(list (list
(dmd-service (shepherd-service
(documentation "Run mingetty on an tty.") (documentation "Run mingetty on an tty.")
(provision (list (symbol-append 'term- (string->symbol tty)))) (provision (list (symbol-append 'term- (string->symbol tty))))
@ -598,8 +598,8 @@ strings or string-valued gexps."
(define mingetty-service-type (define mingetty-service-type
(service-type (name 'mingetty) (service-type (name 'mingetty)
(extensions (list (service-extension dmd-root-service-type (extensions (list (service-extension shepherd-root-service-type
mingetty-dmd-service) mingetty-shepherd-service)
(service-extension pam-root-service-type (service-extension pam-root-service-type
mingetty-pam-service))))) mingetty-pam-service)))))
@ -711,11 +711,11 @@ the tty to run, among other things."
(string-concatenate (string-concatenate
(map cache->config caches))))))) (map cache->config caches)))))))
(define (nscd-dmd-service config) (define (nscd-shepherd-service config)
"Return a dmd service for CONFIG, an <nscd-configuration> object." "Return a shepherd service for CONFIG, an <nscd-configuration> object."
(let ((nscd.conf (nscd.conf-file config)) (let ((nscd.conf (nscd.conf-file config))
(name-services (nscd-configuration-name-services config))) (name-services (nscd-configuration-name-services config)))
(list (dmd-service (list (shepherd-service
(documentation "Run libc's name service cache daemon (nscd).") (documentation "Run libc's name service cache daemon (nscd).")
(provision '(nscd)) (provision '(nscd))
(requirement '(user-processes)) (requirement '(user-processes))
@ -747,8 +747,8 @@ the tty to run, among other things."
(extensions (extensions
(list (service-extension activation-service-type (list (service-extension activation-service-type
(const nscd-activation)) (const nscd-activation))
(service-extension dmd-root-service-type (service-extension shepherd-root-service-type
nscd-dmd-service))) nscd-shepherd-service)))
;; This can be extended by providing additional name services ;; This can be extended by providing additional name services
;; such as nss-mdns. ;; such as nss-mdns.
@ -767,10 +767,10 @@ Service Switch}, for an example."
(service nscd-service-type config)) (service nscd-service-type config))
(define syslog-service-type (define syslog-service-type
(dmd-service-type (shepherd-service-type
'syslog 'syslog
(lambda (config-file) (lambda (config-file)
(dmd-service (shepherd-service
(documentation "Run the syslog daemon (syslogd).") (documentation "Run the syslog daemon (syslogd).")
(provision '(syslogd)) (provision '(syslogd))
(requirement '(user-processes)) (requirement '(user-processes))
@ -885,13 +885,13 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(define %default-guix-configuration (define %default-guix-configuration
(guix-configuration)) (guix-configuration))
(define (guix-dmd-service config) (define (guix-shepherd-service config)
"Return a <dmd-service> for the Guix daemon service with CONFIG." "Return a <shepherd-service> for the Guix daemon service with CONFIG."
(match config (match config
(($ <guix-configuration> guix build-group build-accounts authorize-key? (($ <guix-configuration> guix build-group build-accounts authorize-key?
use-substitutes? substitute-urls extra-options use-substitutes? substitute-urls extra-options
lsof lsh) lsof lsh)
(list (dmd-service (list (shepherd-service
(documentation "Run the Guix daemon.") (documentation "Run the Guix daemon.")
(provision '(guix-daemon)) (provision '(guix-daemon))
(requirement '(user-processes)) (requirement '(user-processes))
@ -941,7 +941,7 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(service-type (service-type
(name 'guix) (name 'guix)
(extensions (extensions
(list (service-extension dmd-root-service-type guix-dmd-service) (list (service-extension shepherd-root-service-type guix-shepherd-service)
(service-extension account-service-type guix-accounts) (service-extension account-service-type guix-accounts)
(service-extension activation-service-type guix-activation) (service-extension activation-service-type guix-activation)
(service-extension profile-service-type (service-extension profile-service-type
@ -963,10 +963,10 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(host guix-publish-configuration-host ;string (host guix-publish-configuration-host ;string
(default "localhost"))) (default "localhost")))
(define guix-publish-dmd-service (define guix-publish-shepherd-service
(match-lambda (match-lambda
(($ <guix-publish-configuration> guix port host) (($ <guix-publish-configuration> guix port host)
(list (dmd-service (list (shepherd-service
(provision '(guix-publish)) (provision '(guix-publish))
(requirement '(guix-daemon)) (requirement '(guix-daemon))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
@ -989,8 +989,8 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(define guix-publish-service-type (define guix-publish-service-type
(service-type (name 'guix-publish) (service-type (name 'guix-publish)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
guix-publish-dmd-service) guix-publish-shepherd-service)
(service-extension account-service-type (service-extension account-service-type
(const %guix-publish-accounts)))))) (const %guix-publish-accounts))))))
@ -1070,8 +1070,8 @@ item of @var{packages}."
(udev-rule "90-kvm.rules" (udev-rule "90-kvm.rules"
"KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n")) "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
(define udev-dmd-service (define udev-shepherd-service
;; Return a <dmd-service> for UDEV with RULES. ;; Return a <shepherd-service> for UDEV with RULES.
(match-lambda (match-lambda
(($ <udev-configuration> udev rules) (($ <udev-configuration> udev rules)
(let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules))) (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules)))
@ -1082,7 +1082,7 @@ item of @var{packages}."
"udev_rules=\"~a/lib/udev/rules.d\"\n" "udev_rules=\"~a/lib/udev/rules.d\"\n"
#$rules)))))) #$rules))))))
(list (list
(dmd-service (shepherd-service
(provision '(udev)) (provision '(udev))
;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
@ -1154,8 +1154,8 @@ item of @var{packages}."
(define udev-service-type (define udev-service-type
(service-type (name 'udev) (service-type (name 'udev)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
udev-dmd-service))) udev-shepherd-service)))
(compose concatenate) ;concatenate the list of rules (compose concatenate) ;concatenate the list of rules
(extend (lambda (config rules) (extend (lambda (config rules)
@ -1172,11 +1172,11 @@ extra rules from the packages listed in @var{rules}."
(udev-configuration (udev udev) (rules rules)))) (udev-configuration (udev udev) (rules rules))))
(define device-mapping-service-type (define device-mapping-service-type
(dmd-service-type (shepherd-service-type
'device-mapping 'device-mapping
(match-lambda (match-lambda
((target open close) ((target open close)
(dmd-service (shepherd-service
(provision (list (symbol-append 'device-mapping- (string->symbol target)))) (provision (list (symbol-append 'device-mapping- (string->symbol target))))
(requirement '(udev)) (requirement '(udev))
(documentation "Map a device node using Linux's device mapper.") (documentation "Map a device node using Linux's device mapper.")
@ -1192,7 +1192,7 @@ gexp, to open it, and evaluate @var{close} to close it."
(list target open close))) (list target open close)))
(define swap-service-type (define swap-service-type
(dmd-service-type (shepherd-service-type
'swap 'swap
(lambda (device) (lambda (device)
(define requirement (define requirement
@ -1201,7 +1201,7 @@ gexp, to open it, and evaluate @var{close} to close it."
(string->symbol (basename device)))) (string->symbol (basename device))))
'())) '()))
(dmd-service (shepherd-service
(provision (list (symbol-append 'swap- (string->symbol device)))) (provision (list (symbol-append 'swap- (string->symbol device))))
(requirement `(udev ,@requirement)) (requirement `(udev ,@requirement))
(documentation "Enable the given swap device.") (documentation "Enable the given swap device.")
@ -1223,10 +1223,10 @@ gexp, to open it, and evaluate @var{close} to close it."
(gpm gpm-configuration-gpm) ;package (gpm gpm-configuration-gpm) ;package
(options gpm-configuration-options)) ;list of strings (options gpm-configuration-options)) ;list of strings
(define gpm-dmd-service (define gpm-shepherd-service
(match-lambda (match-lambda
(($ <gpm-configuration> gpm options) (($ <gpm-configuration> gpm options)
(list (dmd-service (list (shepherd-service
(requirement '(udev)) (requirement '(udev))
(provision '(gpm)) (provision '(gpm))
(start #~(lambda () (start #~(lambda ()
@ -1254,8 +1254,8 @@ gexp, to open it, and evaluate @var{close} to close it."
(define gpm-service-type (define gpm-service-type
(service-type (name 'gpm) (service-type (name 'gpm)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
gpm-dmd-service))))) gpm-shepherd-service)))))
(define* (gpm-service #:key (gpm gpm) (define* (gpm-service #:key (gpm gpm)
(options '("-m" "/dev/input/mice" "-t" "ps2"))) (options '("-m" "/dev/input/mice" "-t" "ps2")))

8
gnu/services/databases.scm
View File

@ -96,7 +96,7 @@ host all all ::1/128 trust"))
(primitive-exit 1)))) (primitive-exit 1))))
(pid (waitpid pid)))))))) (pid (waitpid pid))))))))
(define postgresql-dmd-service (define postgresql-shepherd-service
(match-lambda (match-lambda
(($ <postgresql-configuration> postgresql config-file data-directory) (($ <postgresql-configuration> postgresql config-file data-directory)
(let ((start-script (let ((start-script
@ -112,7 +112,7 @@ host all all ::1/128 trust"))
(string-append "--config-file=" (string-append "--config-file="
#$config-file) #$config-file)
"-D" #$data-directory))))) "-D" #$data-directory)))))
(list (dmd-service (list (shepherd-service
(provision '(postgres)) (provision '(postgres))
(documentation "Run the PostgreSQL daemon.") (documentation "Run the PostgreSQL daemon.")
(requirement '(user-processes loopback)) (requirement '(user-processes loopback))
@ -122,8 +122,8 @@ host all all ::1/128 trust"))
(define postgresql-service-type (define postgresql-service-type
(service-type (name 'postgresql) (service-type (name 'postgresql)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
postgresql-dmd-service) postgresql-shepherd-service)
(service-extension activation-service-type (service-extension activation-service-type
postgresql-activation) postgresql-activation)
(service-extension account-service-type (service-extension account-service-type

8
gnu/services/dbus.scm
View File

@ -159,10 +159,10 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in
(execl prog))) (execl prog)))
(waitpid pid))))))) (waitpid pid)))))))
(define dbus-dmd-service (define dbus-shepherd-service
(match-lambda (match-lambda
(($ <dbus-configuration> dbus) (($ <dbus-configuration> dbus)
(list (dmd-service (list (shepherd-service
(documentation "Run the D-Bus system daemon.") (documentation "Run the D-Bus system daemon.")
(provision '(dbus-system)) (provision '(dbus-system))
(requirement '(user-processes)) (requirement '(user-processes))
@ -174,8 +174,8 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in
(define dbus-root-service-type (define dbus-root-service-type
(service-type (name 'dbus) (service-type (name 'dbus)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
dbus-dmd-service) dbus-shepherd-service)
(service-extension activation-service-type (service-extension activation-service-type
dbus-activation) dbus-activation)
(service-extension etc-service-type (service-extension etc-service-type

20
gnu/services/desktop.scm
View File

@ -165,11 +165,11 @@ is set to @var{value} when the bus daemon launches it."
"UPOWER_CONF_FILE_NAME" "UPOWER_CONF_FILE_NAME"
(upower-configuration-file config)))) (upower-configuration-file config))))
(define (upower-dmd-service config) (define (upower-shepherd-service config)
"Return a dmd service for UPower with CONFIG." "Return a shepherd service for UPower with CONFIG."
(let ((upower (upower-configuration-upower config)) (let ((upower (upower-configuration-upower config))
(config (upower-configuration-file config))) (config (upower-configuration-file config)))
(list (dmd-service (list (shepherd-service
(documentation "Run the UPower power and battery monitor.") (documentation "Run the UPower power and battery monitor.")
(provision '(upower-daemon)) (provision '(upower-daemon))
(requirement '(dbus-system udev)) (requirement '(dbus-system udev))
@ -186,8 +186,8 @@ is set to @var{value} when the bus daemon launches it."
(extensions (extensions
(list (service-extension dbus-root-service-type (list (service-extension dbus-root-service-type
upower-dbus-service) upower-dbus-service)
(service-extension dmd-root-service-type (service-extension shepherd-root-service-type
upower-dmd-service) upower-shepherd-service)
(service-extension activation-service-type (service-extension activation-service-type
(const %upower-activation)) (const %upower-activation))
(service-extension udev-service-type (service-extension udev-service-type
@ -644,13 +644,13 @@ include the @command{udisksctl} command, part of UDisks, and GNOME Disks."
("HybridSleepState" (sleep-list elogind-hybrid-sleep-state)) ("HybridSleepState" (sleep-list elogind-hybrid-sleep-state))
("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode)))) ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode))))
(define (elogind-dmd-service config) (define (elogind-shepherd-service config)
"Return a dmd service for elogind, using @var{config}." "Return a shepherd service for elogind, using @var{config}."
;; TODO: We could probably rely on service activation but the '.service' ;; TODO: We could probably rely on service activation but the '.service'
;; file currently contains an erroneous 'Exec' line. ;; file currently contains an erroneous 'Exec' line.
(let ((config-file (elogind-configuration-file config)) (let ((config-file (elogind-configuration-file config))
(elogind (elogind-package config))) (elogind (elogind-package config)))
(list (dmd-service (list (shepherd-service
(documentation "Run the elogind login and seat management service.") (documentation "Run the elogind login and seat management service.")
(provision '(elogind)) (provision '(elogind))
(requirement '(dbus-system)) (requirement '(dbus-system))
@ -664,8 +664,8 @@ include the @command{udisksctl} command, part of UDisks, and GNOME Disks."
(define elogind-service-type (define elogind-service-type
(service-type (name 'elogind) (service-type (name 'elogind)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
elogind-dmd-service) elogind-shepherd-service)
(service-extension dbus-root-service-type (service-extension dbus-root-service-type
(compose list elogind-package)) (compose list elogind-package))
(service-extension udev-service-type (service-extension udev-service-type

8
gnu/services/lirc.scm
View File

@ -48,10 +48,10 @@
(use-modules (guix build utils)) (use-modules (guix build utils))
(mkdir-p "/var/run/lirc"))) (mkdir-p "/var/run/lirc")))
(define lirc-dmd-service (define lirc-shepherd-service
(match-lambda (match-lambda
(($ <lirc-configuration> lirc device driver config-file options) (($ <lirc-configuration> lirc device driver config-file options)
(list (dmd-service (list (shepherd-service
(provision '(lircd)) (provision '(lircd))
(documentation "Run the LIRC daemon.") (documentation "Run the LIRC daemon.")
(requirement '(user-processes)) (requirement '(user-processes))
@ -73,8 +73,8 @@
(define lirc-service-type (define lirc-service-type
(service-type (name 'lirc) (service-type (name 'lirc)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
lirc-dmd-service) lirc-shepherd-service)
(service-extension activation-service-type (service-extension activation-service-type
(const %lirc-activation)))))) (const %lirc-activation))))))

10
gnu/services/mail.scm
View File

@ -1574,8 +1574,8 @@ greyed out, instead of only later giving \"not selectable\" popup error.
#:owner (getpwnam "root") #:owner (getpwnam "root")
#:common-name (format #f "Dovecot service on ~a" (gethostname)))))) #:common-name (format #f "Dovecot service on ~a" (gethostname))))))
(define (dovecot-dmd-service config) (define (dovecot-shepherd-service config)
"Return a list of <dmd-service> for CONFIG." "Return a list of <shepherd-service> for CONFIG."
(let* ((config-str (let* ((config-str
(cond (cond
((opaque-dovecot-configuration? config) ((opaque-dovecot-configuration? config)
@ -1589,7 +1589,7 @@ greyed out, instead of only later giving \"not selectable\" popup error.
(dovecot (if (opaque-dovecot-configuration? config) (dovecot (if (opaque-dovecot-configuration? config)
(opaque-dovecot-configuration-dovecot config) (opaque-dovecot-configuration-dovecot config)
(dovecot-configuration-dovecot config)))) (dovecot-configuration-dovecot config))))
(list (dmd-service (list (shepherd-service
(documentation "Run the Dovecot POP3/IMAP mail server.") (documentation "Run the Dovecot POP3/IMAP mail server.")
(provision '(dovecot)) (provision '(dovecot))
(requirement '(networking)) (requirement '(networking))
@ -1606,8 +1606,8 @@ greyed out, instead of only later giving \"not selectable\" popup error.
(define dovecot-service-type (define dovecot-service-type
(service-type (name 'dovecot) (service-type (name 'dovecot)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
dovecot-dmd-service) dovecot-shepherd-service)
(service-extension account-service-type (service-extension account-service-type
(const %dovecot-accounts)) (const %dovecot-accounts))
(service-extension pam-root-service-type (service-extension pam-root-service-type

54
gnu/services/networking.scm
View File

@ -98,7 +98,7 @@ fe80::1%lo0 apps.facebook.com\n")
(net-tools static-networking-net-tools)) (net-tools static-networking-net-tools))
(define static-networking-service-type (define static-networking-service-type
(dmd-service-type (shepherd-service-type
'static-networking 'static-networking
(match-lambda (match-lambda
(($ <static-networking> interface ip gateway provision (($ <static-networking> interface ip gateway provision
@ -107,7 +107,7 @@ fe80::1%lo0 apps.facebook.com\n")
;; TODO: Eventually replace 'route' with bindings for the appropriate ;; TODO: Eventually replace 'route' with bindings for the appropriate
;; ioctls. ;; ioctls.
(dmd-service (shepherd-service
;; Unless we're providing the loopback interface, wait for udev to be up ;; Unless we're providing the loopback interface, wait for udev to be up
;; and running so that INTERFACE is actually usable. ;; and running so that INTERFACE is actually usable.
@ -171,7 +171,7 @@ gateway."
(net-tools net-tools)))) (net-tools net-tools))))
(define dhcp-client-service-type (define dhcp-client-service-type
(dmd-service-type (shepherd-service-type
'dhcp-client 'dhcp-client
(lambda (dhcp) (lambda (dhcp)
(define dhclient (define dhclient
@ -180,7 +180,7 @@ gateway."
(define pid-file (define pid-file
"/var/run/dhclient.pid") "/var/run/dhclient.pid")
(dmd-service (shepherd-service
(documentation "Set up networking via DHCP.") (documentation "Set up networking via DHCP.")
(requirement '(user-processes udev)) (requirement '(user-processes udev))
@ -248,7 +248,7 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
(default ntp)) (default ntp))
(servers ntp-configuration-servers)) (servers ntp-configuration-servers))
(define ntp-dmd-service (define ntp-shepherd-service
(match-lambda (match-lambda
(($ <ntp-configuration> ntp servers) (($ <ntp-configuration> ntp servers)
(let () (let ()
@ -271,7 +271,7 @@ restrict -6 ::1\n"))
(define ntpd.conf (define ntpd.conf
(plain-file "ntpd.conf" config)) (plain-file "ntpd.conf" config))
(list (dmd-service (list (shepherd-service
(provision '(ntpd)) (provision '(ntpd))
(documentation "Run the Network Time Protocol (NTP) daemon.") (documentation "Run the Network Time Protocol (NTP) daemon.")
(requirement '(user-processes networking)) (requirement '(user-processes networking))
@ -292,8 +292,8 @@ restrict -6 ::1\n"))
(define ntp-service-type (define ntp-service-type
(service-type (name 'ntp) (service-type (name 'ntp)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
ntp-dmd-service) ntp-shepherd-service)
(service-extension account-service-type (service-extension account-service-type
(const %ntp-accounts)))))) (const %ntp-accounts))))))
@ -376,12 +376,12 @@ HiddenServicePort ~a ~a~%"
#t))) #t)))
#:modules '((guix build utils)))))) #:modules '((guix build utils))))))
(define (tor-dmd-service config) (define (tor-shepherd-service config)
"Return a <dmd-service> running TOR." "Return a <shepherd-service> running TOR."
(match config (match config
(($ <tor-configuration> tor) (($ <tor-configuration> tor)
(let ((torrc (tor-configuration->torrc config))) (let ((torrc (tor-configuration->torrc config)))
(list (dmd-service (list (shepherd-service
(provision '(tor)) (provision '(tor))
;; Tor needs at least one network interface to be up, hence the ;; Tor needs at least one network interface to be up, hence the
@ -421,8 +421,8 @@ HiddenServicePort ~a ~a~%"
(define tor-service-type (define tor-service-type
(service-type (name 'tor) (service-type (name 'tor)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
tor-dmd-service) tor-shepherd-service)
(service-extension account-service-type (service-extension account-service-type
(const %tor-accounts)) (const %tor-accounts))
(service-extension activation-service-type (service-extension activation-service-type
@ -492,7 +492,7 @@ project's documentation} for more information."
(port bitlbee-configuration-port) (port bitlbee-configuration-port)
(extra-settings bitlbee-configuration-extra-settings)) (extra-settings bitlbee-configuration-extra-settings))
(define bitlbee-dmd-service (define bitlbee-shepherd-service
(match-lambda (match-lambda
(($ <bitlbee-configuration> bitlbee interface port extra-settings) (($ <bitlbee-configuration> bitlbee interface port extra-settings)
(let ((conf (plain-file "bitlbee.conf" (let ((conf (plain-file "bitlbee.conf"
@ -504,7 +504,7 @@ project's documentation} for more information."
DaemonPort = " (number->string port) " DaemonPort = " (number->string port) "
" extra-settings)))) " extra-settings))))
(list (dmd-service (list (shepherd-service
(provision '(bitlbee)) (provision '(bitlbee))
(requirement '(user-processes loopback)) (requirement '(user-processes loopback))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
@ -537,8 +537,8 @@ project's documentation} for more information."
(define bitlbee-service-type (define bitlbee-service-type
(service-type (name 'bitlbee) (service-type (name 'bitlbee)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
bitlbee-dmd-service) bitlbee-shepherd-service)
(service-extension account-service-type (service-extension account-service-type
(const %bitlbee-accounts)) (const %bitlbee-accounts))
(service-extension activation-service-type (service-extension activation-service-type
@ -579,9 +579,9 @@ configuration file."
(copy-file (string-append #$wicd file-name) (copy-file (string-append #$wicd file-name)
file-name))))) file-name)))))
(define (wicd-dmd-service wicd) (define (wicd-shepherd-service wicd)
"Return a dmd service for WICD." "Return a shepherd service for WICD."
(list (dmd-service (list (shepherd-service
(documentation "Run the Wicd network manager.") (documentation "Run the Wicd network manager.")
(provision '(networking)) (provision '(networking))
(requirement '(user-processes dbus-system loopback)) (requirement '(user-processes dbus-system loopback))
@ -593,8 +593,8 @@ configuration file."
(define wicd-service-type (define wicd-service-type
(service-type (name 'wicd) (service-type (name 'wicd)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
wicd-dmd-service) wicd-shepherd-service)
(service-extension dbus-root-service-type (service-extension dbus-root-service-type
list) list)
(service-extension activation-service-type (service-extension activation-service-type
@ -624,9 +624,9 @@ and @command{wicd-curses} user interfaces."
(use-modules (guix build utils)) (use-modules (guix build utils))
(mkdir-p "/etc/NetworkManager/system-connections"))) (mkdir-p "/etc/NetworkManager/system-connections")))
(define (network-manager-dmd-service network-manager) (define (network-manager-shepherd-service network-manager)
"Return a dmd service for NETWORK-MANAGER." "Return a shepherd service for NETWORK-MANAGER."
(list (dmd-service (list (shepherd-service
(documentation "Run the NetworkManager.") (documentation "Run the NetworkManager.")
(provision '(networking)) (provision '(networking))
(requirement '(user-processes dbus-system loopback)) (requirement '(user-processes dbus-system loopback))
@ -639,8 +639,8 @@ and @command{wicd-curses} user interfaces."
(define network-manager-service-type (define network-manager-service-type
(service-type (name 'network-manager) (service-type (name 'network-manager)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
network-manager-dmd-service) network-manager-shepherd-service)
(service-extension dbus-root-service-type list) (service-extension dbus-root-service-type list)
(service-extension activation-service-type (service-extension activation-service-type
(const %network-manager-activation)) (const %network-manager-activation))

147
gnu/services/shepherd.scm
View File

@ -32,26 +32,26 @@
#:use-module (srfi srfi-26) #: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 (shepherd-root-service-type
%dmd-root-service %shepherd-root-service
dmd-service-type shepherd-service-type
dmd-service shepherd-service
dmd-service? shepherd-service?
dmd-service-documentation shepherd-service-documentation
dmd-service-provision shepherd-service-provision
dmd-service-requirement shepherd-service-requirement
dmd-service-respawn? shepherd-service-respawn?
dmd-service-start shepherd-service-start
dmd-service-stop shepherd-service-stop
dmd-service-auto-start? shepherd-service-auto-start?
dmd-service-modules shepherd-service-modules
dmd-service-imported-modules shepherd-service-imported-modules
%default-imported-modules %default-imported-modules
%default-modules %default-modules
dmd-service-back-edges)) shepherd-service-back-edges))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -60,7 +60,7 @@
;;; Code: ;;; Code:
(define (dmd-boot-gexp services) (define (shepherd-boot-gexp services)
(mlet %store-monad ((shepherd-conf (shepherd-configuration-file services))) (mlet %store-monad ((shepherd-conf (shepherd-configuration-file services)))
(return #~(begin (return #~(begin
;; Keep track of the booted system. ;; Keep track of the booted system.
@ -81,29 +81,30 @@
(execl (string-append #$shepherd "/bin/shepherd") (execl (string-append #$shepherd "/bin/shepherd")
"shepherd" "--config" #$shepherd-conf))))) "shepherd" "--config" #$shepherd-conf)))))
(define dmd-root-service-type (define shepherd-root-service-type
(service-type (service-type
(name 'dmd-root) (name 'shepherd-root)
;; Extending the root dmd service (aka. PID 1) happens by concatenating the ;; Extending the root shepherd service (aka. PID 1) happens by
;; list of services provided by the extensions. ;; concatenating the list of services provided by the extensions.
(compose concatenate) (compose concatenate)
(extend append) (extend append)
(extensions (list (service-extension boot-service-type dmd-boot-gexp) (extensions (list (service-extension boot-service-type
shepherd-boot-gexp)
(service-extension profile-service-type (service-extension profile-service-type
(const (list shepherd))))))) (const (list shepherd)))))))
(define %dmd-root-service (define %shepherd-root-service
;; The root dmd service, aka. PID 1. Its parameter is a list of ;; The root shepherd service, aka. PID 1. Its parameter is a list of
;; <dmd-service> objects. ;; <shepherd-service> objects.
(service dmd-root-service-type '())) (service shepherd-root-service-type '()))
(define-syntax-rule (dmd-service-type service-name proc) (define-syntax-rule (shepherd-service-type service-name proc)
"Return a <service-type> denoting a simple dmd service--i.e., the type for a "Return a <service-type> denoting a simple shepherd service--i.e., the type
service that extends DMD-ROOT-SERVICE-TYPE and nothing else." for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else."
(service-type (service-type
(name service-name) (name service-name)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
(compose list proc)))))) (compose list proc))))))
(define %default-imported-modules (define %default-imported-modules
@ -118,35 +119,35 @@ service that extends DMD-ROOT-SERVICE-TYPE and nothing else."
(guix build utils) (guix build utils)
(guix build syscalls))) (guix build syscalls)))
(define-record-type* <dmd-service> (define-record-type* <shepherd-service>
dmd-service make-dmd-service shepherd-service make-shepherd-service
dmd-service? shepherd-service?
(documentation dmd-service-documentation ;string (documentation shepherd-service-documentation ;string
(default "[No documentation.]")) (default "[No documentation.]"))
(provision dmd-service-provision) ;list of symbols (provision shepherd-service-provision) ;list of symbols
(requirement dmd-service-requirement ;list of symbols (requirement shepherd-service-requirement ;list of symbols
(default '())) (default '()))
(respawn? dmd-service-respawn? ;Boolean (respawn? shepherd-service-respawn? ;Boolean
(default #t)) (default #t))
(start dmd-service-start) ;g-expression (procedure) (start shepherd-service-start) ;g-expression (procedure)
(stop dmd-service-stop ;g-expression (procedure) (stop shepherd-service-stop ;g-expression (procedure)
(default #~(const #f))) (default #~(const #f)))
(auto-start? dmd-service-auto-start? ;Boolean (auto-start? shepherd-service-auto-start? ;Boolean
(default #t)) (default #t))
(modules dmd-service-modules ;list of module names (modules shepherd-service-modules ;list of module names
(default %default-modules)) (default %default-modules))
(imported-modules dmd-service-imported-modules ;list of module names (imported-modules shepherd-service-imported-modules ;list of module names
(default %default-imported-modules))) (default %default-imported-modules)))
(define (assert-valid-graph services) (define (assert-valid-graph services)
"Raise an error if SERVICES does not define a valid dmd service graph, for "Raise an error if SERVICES does not define a valid shepherd service graph,
instance if a service requires a nonexistent service, or if more than one for instance if a service requires a nonexistent service, or if more than one
service uses a given name. service uses a given name.
These are constraints that dmd's 'register-service' verifies but we'd better These are constraints that shepherd's 'register-service' verifies but we'd
verify them here statically than wait until PID 1 halts with an assertion better verify them here statically than wait until PID 1 halts with an
failure." assertion failure."
(define provisions (define provisions
;; The set of provisions (symbols). Bail out if a symbol is given more ;; The set of provisions (symbols). Bail out if a symbol is given more
;; than once. ;; than once.
@ -159,9 +160,9 @@ failure."
(format #f (_ "service '~a' provided more than once") (format #f (_ "service '~a' provided more than once")
symbol))))))) symbol)))))))
(for-each assert-unique (dmd-service-provision service)) (for-each assert-unique (shepherd-service-provision service))
(fold set-insert set (dmd-service-provision service))) (fold set-insert set (shepherd-service-provision service)))
(setq 'dmd) (setq 'shepherd)
services)) services))
(define (assert-satisfied-requirements service) (define (assert-satisfied-requirements service)
@ -173,51 +174,53 @@ failure."
(message (message
(format #f (_ "service '~a' requires '~a', \ (format #f (_ "service '~a' requires '~a', \
which is undefined") which is undefined")
(match (dmd-service-provision service) (match (shepherd-service-provision service)
((head . _) head) ((head . _) head)
(_ service)) (_ service))
requirement))))))) requirement)))))))
(dmd-service-requirement service))) (shepherd-service-requirement service)))
(for-each assert-satisfied-requirements services)) (for-each assert-satisfied-requirements services))
(define (dmd-service-file-name service) (define (shepherd-service-file-name service)
"Return the file name where the initialization code for SERVICE is to be "Return the file name where the initialization code for SERVICE is to be
stored." stored."
(let ((provisions (string-join (map symbol->string (let ((provisions (string-join (map symbol->string
(dmd-service-provision service))))) (shepherd-service-provision service)))))
(string-append "dmd-" (string-append "shepherd-"
(string-map (match-lambda (string-map (match-lambda
(#\/ #\-) (#\/ #\-)
(chr chr)) (chr chr))
provisions) provisions)
".scm"))) ".scm")))
(define (dmd-service-file service) (define (shepherd-service-file service)
"Return a file defining SERVICE." "Return a file defining SERVICE."
(gexp->file (dmd-service-file-name service) (gexp->file (shepherd-service-file-name service)
#~(begin #~(begin
(use-modules #$@(dmd-service-modules service)) (use-modules #$@(shepherd-service-modules service))
(make <service> (make <service>
#:docstring '#$(dmd-service-documentation service) #:docstring '#$(shepherd-service-documentation service)
#:provides '#$(dmd-service-provision service) #:provides '#$(shepherd-service-provision service)
#:requires '#$(dmd-service-requirement service) #:requires '#$(shepherd-service-requirement service)
#:respawn? '#$(dmd-service-respawn? service) #:respawn? '#$(shepherd-service-respawn? service)
#:start #$(dmd-service-start service) #:start #$(shepherd-service-start service)
#:stop #$(dmd-service-stop service))))) #:stop #$(shepherd-service-stop service)))))
(define (shepherd-configuration-file services) (define (shepherd-configuration-file services)
"Return the shepherd configuration file for SERVICES." "Return the shepherd configuration file for SERVICES."
(define modules (define modules
(delete-duplicates (delete-duplicates
(append-map dmd-service-imported-modules services))) (append-map shepherd-service-imported-modules services)))
(assert-valid-graph services) (assert-valid-graph services)
(mlet %store-monad ((modules (imported-modules modules)) (mlet %store-monad ((modules (imported-modules modules))
(compiled (compiled-modules modules)) (compiled (compiled-modules modules))
(files (mapm %store-monad dmd-service-file services))) (files (mapm %store-monad
shepherd-service-file
services)))
(define config (define config
#~(begin #~(begin
(eval-when (expand load eval) (eval-when (expand load eval)
@ -238,20 +241,20 @@ stored."
(format #t "starting services...~%") (format #t "starting services...~%")
(for-each start (for-each start
'#$(append-map dmd-service-provision '#$(append-map shepherd-service-provision
(filter dmd-service-auto-start? (filter shepherd-service-auto-start?
services))))) services)))))
(gexp->file "shepherd.conf" config))) (gexp->file "shepherd.conf" config)))
(define (dmd-service-back-edges services) (define (shepherd-service-back-edges services)
"Return a procedure that, when given a <dmd-service> from SERVICES, returns "Return a procedure that, when given a <shepherd-service> from SERVICES,
the list of <dmd-service> that depend on it." returns the list of <shepherd-service> that depend on it."
(define provision->service (define provision->service
(let ((services (fold (lambda (service result) (let ((services (fold (lambda (service result)
(fold (cut vhash-consq <> service <>) (fold (cut vhash-consq <> service <>)
result result
(dmd-service-provision service))) (shepherd-service-provision service)))
vlist-null vlist-null
services))) services)))
(lambda (name) (lambda (name)
@ -265,7 +268,7 @@ the list of <dmd-service> that depend on it."
(vhash-consq (provision->service requirement) service (vhash-consq (provision->service requirement) service
edges)) edges))
edges edges
(dmd-service-requirement service))) (shepherd-service-requirement service)))
vlist-null vlist-null
services)) services))

10
gnu/services/ssh.scm
View File

@ -103,8 +103,8 @@
(lsh-configuration-host-key config)) (lsh-configuration-host-key config))
#t))) #t)))
(define (lsh-dmd-service config) (define (lsh-shepherd-service config)
"Return a <dmd-service> for lsh with CONFIG." "Return a <shepherd-service> for lsh with CONFIG."
(define lsh (lsh-configuration-lsh config)) (define lsh (lsh-configuration-lsh config))
(define pid-file (lsh-configuration-pid-file config)) (define pid-file (lsh-configuration-pid-file config))
(define pid-file? (lsh-configuration-pid-file? config)) (define pid-file? (lsh-configuration-pid-file? config))
@ -151,7 +151,7 @@
'(networking syslogd) '(networking syslogd)
'(networking))) '(networking)))
(list (dmd-service (list (shepherd-service
(documentation "GNU lsh SSH server") (documentation "GNU lsh SSH server")
(provision '(ssh-daemon)) (provision '(ssh-daemon))
(requirement requires) (requirement requires)
@ -168,8 +168,8 @@
(define lsh-service-type (define lsh-service-type
(service-type (name 'lsh) (service-type (name 'lsh)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
lsh-dmd-service) lsh-shepherd-service)
(service-extension pam-root-service-type (service-extension pam-root-service-type
lsh-pam-services) lsh-pam-services)
(service-extension activation-service-type (service-extension activation-service-type

8
gnu/services/web.scm
View File

@ -79,7 +79,7 @@
(system* (string-append #$nginx "/bin/nginx") (system* (string-append #$nginx "/bin/nginx")
"-c" #$config-file "-t"))))) "-c" #$config-file "-t")))))
(define nginx-dmd-service (define nginx-shepherd-service
(match-lambda (match-lambda
(($ <nginx-configuration> nginx log-directory run-directory config-file) (($ <nginx-configuration> nginx log-directory run-directory config-file)
(let* ((nginx-binary #~(string-append #$nginx "/sbin/nginx")) (let* ((nginx-binary #~(string-append #$nginx "/sbin/nginx"))
@ -90,7 +90,7 @@
(system* #$nginx-binary "-c" #$config-file #$@args)))))) (system* #$nginx-binary "-c" #$config-file #$@args))))))
;; TODO: Add 'reload' action. ;; TODO: Add 'reload' action.
(list (dmd-service (list (shepherd-service
(provision '(nginx)) (provision '(nginx))
(documentation "Run the nginx daemon.") (documentation "Run the nginx daemon.")
(requirement '(user-processes loopback)) (requirement '(user-processes loopback))
@ -100,8 +100,8 @@
(define nginx-service-type (define nginx-service-type
(service-type (name 'nginx) (service-type (name 'nginx)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
nginx-dmd-service) nginx-shepherd-service)
(service-extension activation-service-type (service-extension activation-service-type
nginx-activation) nginx-activation)
(service-extension account-service-type (service-extension account-service-type

8
gnu/services/xorg.scm
View File

@ -250,7 +250,7 @@ which should be passed to this script as the first argument. If not, the
#:allow-empty-passwords? #:allow-empty-passwords?
(slim-configuration-allow-empty-passwords? config)))) (slim-configuration-allow-empty-passwords? config))))
(define (slim-dmd-service config) (define (slim-shepherd-service config)
(define slim.cfg (define slim.cfg
(let ((xinitrc (xinitrc #:fallback-session (let ((xinitrc (xinitrc #:fallback-session
(slim-configuration-auto-login-session config))) (slim-configuration-auto-login-session config)))
@ -285,7 +285,7 @@ reboot_cmd " shepherd "/sbin/reboot\n"
(define theme (define theme
(slim-configuration-theme config)) (slim-configuration-theme config))
(list (dmd-service (list (shepherd-service
(documentation "Xorg display server") (documentation "Xorg display server")
(provision '(xorg-server)) (provision '(xorg-server))
(requirement '(user-processes host-name udev)) (requirement '(user-processes host-name udev))
@ -308,8 +308,8 @@ reboot_cmd " shepherd "/sbin/reboot\n"
(define slim-service-type (define slim-service-type
(service-type (name 'slim) (service-type (name 'slim)
(extensions (extensions
(list (service-extension dmd-root-service-type (list (service-extension shepherd-root-service-type
slim-dmd-service) slim-shepherd-service)
(service-extension pam-root-service-type (service-extension pam-root-service-type
slim-pam-service) slim-pam-service)

10
gnu/system.scm
View File

@ -303,11 +303,11 @@ a container or that of a \"bare metal\" system."
(cons* (service system-service-type entries) (cons* (service system-service-type entries)
%boot-service %boot-service
;; %DMD-ROOT-SERVICE must come first so that the gexp that execs ;; %SHEPHERD-ROOT-SERVICE must come first so that the gexp that
;; dmd comes last in the boot script (XXX). Likewise, the cleanup ;; execs shepherd comes last in the boot script (XXX). Likewise,
;; service must come last so that its gexp runs before activation ;; the cleanup service must come last so that its gexp runs before
;; code. ;; activation code.
%dmd-root-service %shepherd-root-service
%activation-service %activation-service
(service cleanup-service-type #f) (service cleanup-service-type #f)

4
gnu/system/install.scm
View File

@ -164,10 +164,10 @@ current store is on a RAM disk."
(rmdir "/.rw-store")))))) (rmdir "/.rw-store"))))))
(define cow-store-service-type (define cow-store-service-type
(dmd-service-type (shepherd-service-type
'cow-store 'cow-store
(lambda _ (lambda _
(dmd-service (shepherd-service
(requirement '(root-file-system user-processes)) (requirement '(root-file-system user-processes))
(provision '(cow-store)) (provision '(cow-store))
(documentation (documentation

24
guix/scripts/system.scm
View File

@ -313,17 +313,17 @@ list of services."
(edges (lift1 (service-back-edges services) %store-monad)))) (edges (lift1 (service-back-edges services) %store-monad))))
(define (dmd-service-node-label service) (define (dmd-service-node-label service)
"Return a label for a node representing a <dmd-service>." "Return a label for a node representing a <shepherd-service>."
(string-join (map symbol->string (dmd-service-provision service)))) (string-join (map symbol->string (shepherd-service-provision service))))
(define (dmd-service-node-type services) (define (dmd-service-node-type services)
"Return a node type for SERVICES, a list of <dmd-service>." "Return a node type for SERVICES, a list of <shepherd-service>."
(node-type (node-type
(name "dmd-service") (name "dmd-service")
(description "the dependency graph of dmd services") (description "the dependency graph of dmd services")
(identifier (lift1 dmd-service-node-label %store-monad)) (identifier (lift1 dmd-service-node-label %store-monad))
(label dmd-service-node-label) (label dmd-service-node-label)
(edges (lift1 (dmd-service-back-edges services) %store-monad)))) (edges (lift1 (shepherd-service-back-edges services) %store-monad))))
;;; ;;;
@ -475,14 +475,14 @@ building anything."
#:reverse-edges? #t))) #:reverse-edges? #t)))
(define (export-dmd-graph os port) (define (export-dmd-graph os port)
"Export the graph of dmd services of OS to PORT." "Export the graph of shepherd services of OS to PORT."
(let* ((services (operating-system-services os)) (let* ((services (operating-system-services os))
(pid1 (fold-services services (pid1 (fold-services services
#:target-type dmd-root-service-type)) #:target-type shepherd-root-service-type))
(dmds (service-parameters pid1)) ;the list of <dmd-service> (shepherds (service-parameters pid1)) ;list of <shepherd-service>
(sinks (filter (lambda (service) (sinks (filter (lambda (service)
(null? (dmd-service-requirement service))) (null? (shepherd-service-requirement service)))
dmds))) shepherds)))
(export-graph sinks (current-output-port) (export-graph sinks (current-output-port)
#:node-type (dmd-service-node-type dmds) #:node-type (dmd-service-node-type dmds)
#:reverse-edges? #t))) #:reverse-edges? #t)))

4
tests/guix-system.sh
View File

@ -121,10 +121,10 @@ cat > "$tmpfile" <<EOF
(use-service-modules networking) (use-service-modules networking)
(define buggy-service-type (define buggy-service-type
(dmd-service-type (shepherd-service-type
'buggy 'buggy
(lambda _ (lambda _
(dmd-service (shepherd-service
(provision '(buggy!)) (provision '(buggy!))
(requirement '(does-not-exist)) (requirement '(does-not-exist))
(start #t))))) (start #t)))))

14
tests/services.scm
View File

@ -105,11 +105,15 @@
(fold-services (list s) #:target-type t1) (fold-services (list s) #:target-type t1)
#f))) #f)))
(test-assert "dmd-service-back-edges" (test-assert "shepherd-service-back-edges"
(let* ((s1 (dmd-service (provision '(s1)) (start #f))) (let* ((s1 (shepherd-service (provision '(s1)) (start #f)))
(s2 (dmd-service (provision '(s2)) (requirement '(s1)) (start #f))) (s2 (shepherd-service (provision '(s2))
(s3 (dmd-service (provision '(s3)) (requirement '(s1 s2)) (start #f))) (requirement '(s1))
(e (dmd-service-back-edges (list s1 s2 s3)))) (start #f)))
(s3 (shepherd-service (provision '(s3))
(requirement '(s1 s2))
(start #f)))
(e (shepherd-service-back-edges (list s1 s2 s3))))
(and (lset= eq? (e s1) (list s2 s3)) (and (lset= eq? (e s1) (list s2 s3))
(lset= eq? (e s2) (list s3)) (lset= eq? (e s2) (list s3))
(null? (e s3))))) (null? (e s3)))))