services: Introduce extensible services.

This patch rewrites GuixSD services to make them extensible.

* gnu-system.am (GNU_SYSTEM_MODULES): Add gnu/services/dbus.scm.
* gnu/services.scm (<service>): Replace with new record type.
  (<service-extension>, <service-type>): New record types.
  (write-service-type, compute-boot-script, second-argument): New
  procedures.
  (%boot-service, boot-service-type): New variables.
  (file-union, directory-union, modprobe-wrapper,
  activation-service->script, activation-script,
  gexps->activation-gexp): New procedures.
  (activation-service-type, %activation-service): New variables.
  (etc-directory, files->etc-directory, etc-service): New procedures.
  (etc-service-type, setuid-program-service, firmware-service-type): New
  variables.
  (firmware->activation-gexp): New procedure.
  (&service-error, &missing-target-service-error,
  &ambiguous-target-service-error): New condition types.
  (service-back-edges, fold-services): New procedures.
* gnu/services/avahi.scm (<avahi-configuration>): New record type.
  (configuration-file): Replace keyword parameters with a single
  'config' parameter.
  (%avahi-accounts, %avahi-activation, avahi-service-type): New
  variables.
  (avahi-dmd-service): New procedure.
  (avahi-service): Rewrite using 'service' and 'avahi-configuration'.
* gnu/services/base.scm (%root-file-system-dmd-service,
  root-file-system-service-type): New variables.
  (root-file-system-service): Use them.
  (file-system->dmd-service-name): New procedure.
  (file-system-service-type): New variable.
  (file-system-service): Use it.  Replace keyword parameters with a
  single 'file-system' object.
  (user-unmount-service-type): New variable.
  (user-unmount-service): Use it.
  (user-processes-service-type): New variable.
  (user-processes-service): Use it.
  (host-name-service-type): New variable.
  (host-name-service): Use it.
  (console-keymap-service-type): New variable.
  (console-keymap-service): Use it.
  (console-font-service-type): New variable.
  (console-font-service): Use it.
  (mingetty-pam-service, mingetty-dmd-service): New procedures.
  (mingetty-service-type): New variable.
  (mingetty-service): Use it.
  (nscd-dmd-service): New procedure.
  (nscd-activation, nscd-service-type): New variables.
  (nscd-service): Use the latter.
  (syslog-service-type): New variable.
  (syslog-service): Use it.
  (<guix-configuration>): New record type.
  (%default-guix-configuration): New variable.
  (guix-dmd-service, guix-accounts, guix-activation): New procedures.
  (guix-service-type): New variable.
  (guix-service): Replace list of keyword parameters with a single
  'config' parameter.  Rewrite using 'service'.
  (<udev-configuration>): New record type.
  (udev-dmd-service): New procedure.
  (udev-service-type): New variable.
  (udev-service): Use it.
  (device-mapping-service-type): New variable.
  (device-mapping-service): Use it.
  (swap-service-type): New variable.
  (swap-service): Use it.
* gnu/services/databases.scm (<postgresql-configuration>): New record
  type.
  (%postgresql-accounts, postgresql-activation): New variables.
  (postgresql-dmd-service): New procedure.
  (postgresql-service): Rewrite using 'service' and
  'postgresql-configuration'.
* gnu/services/dbus.scm: New file.
* gnu/services/desktop.scm (dbus-configuration-directory, dbus-service):
  Remove.
  (wrapped-dbus-service): New procedure.
  (<upower-configuration>): New record type.
  (upower-configuration-file): Replace keyword parameters with single
  <upower-configuration> parameter.
  (%upower-accounts, %upower-activation): New variables.
  (upower-dbus-service, upower-dmd-service): New procedures.
  (upower-service-type): New variable.
  (upower-service): Rewrite using 'service' and 'upower-configuration'.
  (%colord-activation, %colord-accounts): New variables.
  (colord-dmd-service): New procedure.
  (colord-service-type): New variable.
  (colord-service): Rewrite using 'service'.
  (<geoclue-configuration>): New record type.
  (geoclue-configuration-file): Replace keyword parameters with a single
  'config' parameter.
  (geoclue-dbus-service, geoclue-dmd-service): New procedures.
  (%geoclue-accounts, geoclue-service-type): New variables.
  (geoclue-service): Rewrite using 'service' and
  'geoclue-configuration'.
  (%polkit-accounts, %polkit-pam-services, polkit-service-type): New
  variables.
  (polkit-dmd-service): New procedure.
  (polkit-service): Rewrite using 'service'.
  (<elogind-configuration>)[elogind]: New field.
  (elogind-dmd-service): New procedure.
  (elogind-service-type): New variable.
  (elogind-service): Rewrite using 'service'.
  (%desktop-services): Remove argument to 'dbus-service'.  Remove 'map'
  over %BASE-SERVICES.
* gnu/services/dmd.scm (dmd-boot-gexp): New procedure.
  (dmd-root-service-type, %dmd-root-service): New variables.
  (dmd-service-type): New macro.
  (<dmd-service>): New record type.
* gnu/services/lirc.scm (<lirc-configuration>): New record type.
  (%lirc-activation): New variable.
  (lirc-dmd-service): New procedure.
  (lirc-service-type): New variable.
  (lirc-service): Rewrite using 'service' and 'lirc-configuration'.
* gnu/services/networking.scm (<static-networking>): New record type.
  (static-networking-service-type): New variable.
  (static-networking-service): Rewrite using 'service' and
  'static-networking'.
  (dhcp-client-service-type): New variable.
  (dhcp-client-service): Rewrite using 'service'.
  (<ntp-configuration>): New record type.
  (ntp-dmd-service): New procedure.
  (ntp-service-type): New variable.
  (ntp-service): New procedure.
  (%tor-accounts, tor-service-type): New variable.
  (tor-dmd-service): New procedure.
  (tor-service): Rewrite using 'service'.
  (<bitlbee-configuration>): New record type.
  (bitlbee-dmd-service): New procedure.
  (%bitlbee-accounts, %bitlbee-activation, bitlbee-service-type): New
  variables.
  (bitlbee-service): Rewrite using 'service'.
  (%wicd-activation): New variable.
  (wicd-dmd-service): New procedure.
  (wicd-service-type): New variable.
  (wicd-service): Rewrite using 'service'.
* gnu/services/ssh.scm (<lsh-configuration>): New record type.
  (activation): Rename to...
  (lsh-initialization): ... this.
  (lsh-activation, lsh-dmd-service, lsh-pam-services): New procedures.
  (lsh-service-type): New variable.
  (lsh-service): Rewrite using 'service' and 'lsh-configuration'.
* gnu/services/web.scm (<nginx-configuration>): New record type.
  (%nginx-accounts): New variable.
  (nginx-activation, nginx-dmd-service): New procedures.
  (nginx-service-type): New variable.
  (nginx-service): Rewrite using 'service' and 'nginx-configuration'.
* gnu/services/xorg.scm (<slim-configuration>): New record type.
  (slim-pam-service, slim-dmd-service): New procedures.
  (slim-service-type): New variable.
  (slim-service): Rewrite using 'service' and 'slim-configuration'.
* gnu/system.scm (file-union): Remove.
  (other-file-system-services): Adjust to new 'file-system-service'
  signature.
  (essential-services): Add #:container? parameter.  Add
  %DMD-ROOT-SERVICE, %ACTIVATION-SERVICE, and calls to
  'pam-root-service', 'account-service', 'operating-system-etc-service',
  and a SETUID-PROGRAM-SERVICE instance.
  (operating-system-services): Pass #:container? to 'essential-services.
  (etc-directory): Remove.
  (operating-system-etc-service): New procedure.  Rewrite as a call to
  'etc-service'.
  (operating-system-accounts): Change to not return accounts required by
  services.
  (operating-system-etc-directory): Rewrite as a call to 'fold-services'
  and 'etc-directory'.
  (user-group->gexp, user-account->gexp, modprobe-wrapper): Remove.
  (operating-system-activation-script): Rewrite as a call to
  'fold-services' and 'activation-service->script'.
  (operating-system-boot-script): Likewise.
  (operating-system-derivation): Add call to 'lower-object'.
  (emacs-site-file, emacs-site-directory, shells-file): Change to use
  'computed-file' and 'scheme-file' instead of the monadic procedures.
* gnu/system/install.scm (cow-store-service-type): New variable.
  (cow-store-service): Rewrite using 'service'.
  (/etc/configuration-files): New procedure.
  (configuration-template-service-type,
  %configuration-template-service): New variables.
  (configuration-template-service): Remove.
  (installation-services): Adjust accordingly.  Adjust argument to
  'guix-service'.
* gnu/system/linux.scm (/etc-entry, pam-root-service): New procedures.
  (pam-root-service-type): New variable.
* gnu/system/shadow.scm (user-group->gexp, user-account->gexp,
  account-activation, etc-skel, account-service): New procedures.
  (account-service-type): New variable.
* tests/services.scm: New file.
* doc/guix.texi (Base Services, Desktop Services): Adjust accordingly.
  (Defining Services): Rewrite.
* doc/images/service-graph.dot: New file.
* doc.am (DOT_FILES): Add it.
* po/guix/POTFILES.in: Add gnu/services.scm.

1 files changed, 595 insertions, 414 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index d9d73b4597..adafe1b55e 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -21,9 +21,11 @@
 (define-module (gnu services base)
   #:use-module (guix store)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
   #:use-module (gnu services networking)
   #:use-module (gnu system shadow)                ; 'user-account', etc.
   #:use-module (gnu system linux)                 ; 'pam-service', etc.
+  #:use-module (gnu system file-systems)          ; 'file-system', etc.
   #:use-module (gnu packages admin)
   #:use-module ((gnu packages linux)
                 #:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda))
@@ -49,6 +51,7 @@
             host-name-service
             console-keymap-service
             console-font-service
+            udev-service-type
             udev-service
 
             mingetty-configuration
@@ -64,9 +67,14 @@
             nscd-cache
             nscd-cache?
 
+            nscd-service-type
             nscd-service
             syslog-service
+
+            guix-configuration
+            guix-configuration?
             guix-service
+
             %base-services))
 
 ;;; Commentary:
@@ -76,13 +84,13 @@
 ;;;
 ;;; Code:
 
-(define (root-file-system-service)
-  "Return a service whose sole purpose is to re-mount read-only the root file
-system upon shutdown (aka. cleanly \"umounting\" root.)
+
+;;;
+;;; File systems.
+;;;
 
-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."
-  (service
+(define %root-file-system-dmd-service
+  (dmd-service
    (documentation "Take care of the root file system.")
    (provision '(root-file-system))
    (start #~(const #t))
@@ -116,181 +124,230 @@ This service must be the root of the service dependency graph so that its
                   #f)))))
    (respawn? #f)))
 
-(define* (file-system-service device target type
-                              #:key (flags '()) (check? #t)
-                              create-mount-point? options (title 'any)
-                              (requirements '()))
-  "Return a service that mounts DEVICE on TARGET as a file system TYPE with
-OPTIONS.  TITLE is a symbol specifying what kind of name DEVICE is: 'label for
-a partition label, 'device for a device file name, or 'any.  When CHECK? is
-true, check the file system before mounting it.  When CREATE-MOUNT-POINT? is
-true, create TARGET if it does not exist yet.  FLAGS is a list of symbols,
-such as 'read-only' etc.  Optionally, REQUIREMENTS may be a list of service
-names such as device-mapping services."
-  (service
-   (provision (list (symbol-append 'file-system- (string->symbol target))))
-   (requirement `(root-file-system ,@requirements))
-   (documentation "Check, mount, and unmount the given file system.")
-   (start #~(lambda args
-              ;; FIXME: Use or factorize with 'mount-file-system'.
-              (let ((device (canonicalize-device-spec #$device '#$title))
-                    (flags  #$(mount-flags->bit-mask flags)))
-                #$(if create-mount-point?
-                      #~(mkdir-p #$target)
-                      #~#t)
-                #$(if check?
-                      #~(begin
-                          ;; Make sure fsck.ext2 & co. can be found.
-                          (setenv "PATH"
-                                  (string-append
-                                   #$e2fsprogs "/sbin:"
-                                   "/run/current-system/profile/sbin:"
-                                   (getenv "PATH")))
-                          (check-file-system device #$type))
-                      #~#t)
-
-                (mount device #$target #$type flags #$options)
-
-                ;; For read-only bind mounts, an extra remount is needed,
-                ;; as per <http://lwn.net/Articles/281157/>, which still
-                ;; applies to Linux 4.0.
-                (when (and (= MS_BIND (logand flags MS_BIND))
-                           (= MS_RDONLY (logand flags MS_RDONLY)))
-                  (mount device #$target #$type
-                         (logior MS_BIND MS_REMOUNT MS_RDONLY))))
-              #t))
-   (stop #~(lambda args
-             ;; Normally there are no processes left at this point, so
-             ;; TARGET can be safely unmounted.
-
-             ;; Make sure PID 1 doesn't keep TARGET busy.
-             (chdir "/")
-
-             (umount #$target)
-             #f))))
+(define root-file-system-service-type
+  (dmd-service-type (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
+system upon shutdown (aka. cleanly \"umounting\" root.)
+
+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."
+  (service root-file-system-service-type #f))
+
+(define (file-system->dmd-service-name file-system)
+  "Return the symbol that denotes the service mounting and unmounting
+FILE-SYSTEM."
+  (symbol-append 'file-system-
+                 (string->symbol (file-system-mount-point file-system))))
+
+(define file-system-service-type
+  ;; TODO(?): Make this an extensible service that takes <file-system> objects
+  ;; and returns a list of <dmd-service>.
+  (dmd-service-type
+   (lambda (file-system)
+     (let ((target  (file-system-mount-point file-system))
+           (device  (file-system-device file-system))
+           (type    (file-system-type file-system))
+           (title   (file-system-title file-system))
+           (check?  (file-system-check? file-system))
+           (create? (file-system-create-mount-point? file-system))
+           (dependencies (file-system-dependencies file-system)))
+       (dmd-service
+        (provision (list (file-system->dmd-service-name file-system)))
+        (requirement `(root-file-system
+                       ,@(map file-system->dmd-service-name dependencies)))
+        (documentation "Check, mount, and unmount the given file system.")
+        (start #~(lambda args
+                   ;; FIXME: Use or factorize with 'mount-file-system'.
+                   (let ((device (canonicalize-device-spec #$device '#$title))
+                         (flags  #$(mount-flags->bit-mask
+                                    (file-system-flags file-system))))
+                     #$(if create?
+                           #~(mkdir-p #$target)
+                           #~#t)
+                     #$(if check?
+                           #~(begin
+                               ;; Make sure fsck.ext2 & co. can be found.
+                               (setenv "PATH"
+                                       (string-append
+                                        #$e2fsprogs "/sbin:"
+                                        "/run/current-system/profile/sbin:"
+                                        (getenv "PATH")))
+                               (check-file-system device #$type))
+                           #~#t)
+
+                     (mount device #$target #$type flags
+                            #$(file-system-options file-system))
+
+                     ;; For read-only bind mounts, an extra remount is needed,
+                     ;; as per <http://lwn.net/Articles/281157/>, which still
+                     ;; applies to Linux 4.0.
+                     (when (and (= MS_BIND (logand flags MS_BIND))
+                                (= MS_RDONLY (logand flags MS_RDONLY)))
+                       (mount device #$target #$type
+                              (logior MS_BIND MS_REMOUNT MS_RDONLY))))
+                   #t))
+        (stop #~(lambda args
+                  ;; Normally there are no processes left at this point, so
+                  ;; TARGET can be safely unmounted.
+
+                  ;; Make sure PID 1 doesn't keep TARGET busy.
+                  (chdir "/")
+
+                  (umount #$target)
+                  #f)))))))
+
+(define* (file-system-service file-system)
+  "Return a service that mounts @var{file-system}, a @code{<file-system>}
+object."
+  (service file-system-service-type file-system))
+
+(define user-unmount-service-type
+  (dmd-service-type
+   (lambda (known-mount-points)
+     (dmd-service
+      (documentation "Unmount manually-mounted file systems.")
+      (provision '(user-unmount))
+      (start #~(const #t))
+      (stop #~(lambda args
+                (define (known? mount-point)
+                  (member mount-point
+                          (cons* "/proc" "/sys" '#$known-mount-points)))
+
+                ;; Make sure we don't keep the user's mount points busy.
+                (chdir "/")
+
+                (for-each (lambda (mount-point)
+                            (format #t "unmounting '~a'...~%" mount-point)
+                            (catch 'system-error
+                              (lambda ()
+                                (umount mount-point))
+                              (lambda args
+                                (let ((errno (system-error-errno args)))
+                                  (format #t "failed to unmount '~a': ~a~%"
+                                          mount-point (strerror errno))))))
+                          (filter (negate known?) (mount-points)))
+                #f))))))
 
 (define (user-unmount-service known-mount-points)
   "Return a service whose sole purpose is to unmount file systems not listed
 in KNOWN-MOUNT-POINTS when it is stopped."
-  (service
-   (documentation "Unmount manually-mounted file systems.")
-   (provision '(user-unmount))
-   (start #~(const #t))
-   (stop #~(lambda args
-             (define (known? mount-point)
-               (member mount-point
-                       (cons* "/proc" "/sys"
-                              '#$known-mount-points)))
-
-             ;; Make sure we don't keep the user's mount points busy.
-             (chdir "/")
-
-             (for-each (lambda (mount-point)
-                         (format #t "unmounting '~a'...~%" mount-point)
-                         (catch 'system-error
-                           (lambda ()
-                             (umount mount-point))
-                           (lambda args
-                             (let ((errno (system-error-errno args)))
-                               (format #t "failed to unmount '~a': ~a~%"
-                                       mount-point (strerror errno))))))
-                       (filter (negate known?) (mount-points)))
-             #f))))
+  (service user-unmount-service-type known-mount-points))
 
 (define %do-not-kill-file
   ;; Name of the file listing PIDs of processes that must survive when halting
   ;; the system.  Typical example is user-space file systems.
   "/etc/dmd/do-not-kill")
 
-(define* (user-processes-service requirements #:key (grace-delay 4))
+(define user-processes-service-type
+  (dmd-service-type
+   (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)))
+       (start #~(const #t))
+       (stop #~(lambda _
+                 (define (kill-except omit signal)
+                   ;; Kill all the processes with SIGNAL except those listed
+                   ;; in OMIT and the current process.
+                   (let ((omit (cons (getpid) omit)))
+                     (for-each (lambda (pid)
+                                 (unless (memv pid omit)
+                                   (false-if-exception
+                                    (kill pid signal))))
+                               (processes))))
+
+                 (define omitted-pids
+                   ;; List of PIDs that must not be killed.
+                   (if (file-exists? #$%do-not-kill-file)
+                       (map string->number
+                            (call-with-input-file #$%do-not-kill-file
+                              (compose string-tokenize
+                                       (@ (ice-9 rdelim) read-string))))
+                       '()))
+
+                 (define (now)
+                   (car (gettimeofday)))
+
+                 (define (sleep* n)
+                   ;; Really sleep N seconds.
+                   ;; Work around <http://bugs.gnu.org/19581>.
+                   (define start (now))
+                   (let loop ((elapsed 0))
+                     (when (> n elapsed)
+                       (sleep (- n elapsed))
+                       (loop (- (now) start)))))
+
+                 (define lset= (@ (srfi srfi-1) lset=))
+
+                 (display "sending all processes the TERM signal\n")
+
+                 (if (null? omitted-pids)
+                     (begin
+                       ;; Easy: terminate all of them.
+                       (kill -1 SIGTERM)
+                       (sleep* #$grace-delay)
+                       (kill -1 SIGKILL))
+                     (begin
+                       ;; Kill them all except OMITTED-PIDS.  XXX: We would
+                       ;; like to (kill -1 SIGSTOP) to get a fixed list of
+                       ;; processes, like 'killall5' does, but that seems
+                       ;; unreliable.
+                       (kill-except omitted-pids SIGTERM)
+                       (sleep* #$grace-delay)
+                       (kill-except omitted-pids SIGKILL)
+                       (delete-file #$%do-not-kill-file)))
+
+                 (let wait ()
+                   (let ((pids (processes)))
+                     (unless (lset= = pids (cons 1 omitted-pids))
+                       (format #t "waiting for process termination\
+ (processes left: ~s)~%"
+                               pids)
+                       (sleep* 2)
+                       (wait))))
+
+                 (display "all processes have been terminated\n")
+                 #f))
+       (respawn? #f))))))
+
+(define* (user-processes-service file-systems #:key (grace-delay 4))
   "Return the service that is responsible for terminating all the processes so
 that the root file system can be re-mounted read-only, just before
 rebooting/halting.  Processes still running GRACE-DELAY seconds after SIGTERM
 has been sent are terminated with SIGKILL.
 
-The returned service will depend on 'root-file-system' and on all the services
-listed in REQUIREMENTS.
+The returned service will depend on 'root-file-system' and on all the dmd
+services corresponding to FILE-SYSTEMS.
 
 All the services that spawn processes must depend on this one so that they are
 stopped before 'kill' is called."
-  (service
-   (documentation "When stopped, terminate all user processes.")
-   (provision '(user-processes))
-   (requirement (cons 'root-file-system requirements))
-   (start #~(const #t))
-   (stop #~(lambda _
-             (define (kill-except omit signal)
-               ;; Kill all the processes with SIGNAL except those
-               ;; listed in OMIT and the current process.
-               (let ((omit (cons (getpid) omit)))
-                 (for-each (lambda (pid)
-                             (unless (memv pid omit)
-                               (false-if-exception
-                                (kill pid signal))))
-                           (processes))))
-
-             (define omitted-pids
-               ;; List of PIDs that must not be killed.
-               (if (file-exists? #$%do-not-kill-file)
-                   (map string->number
-                        (call-with-input-file #$%do-not-kill-file
-                          (compose string-tokenize
-                                   (@ (ice-9 rdelim) read-string))))
-                   '()))
-
-             (define (now)
-               (car (gettimeofday)))
-
-             (define (sleep* n)
-               ;; Really sleep N seconds.
-               ;; Work around <http://bugs.gnu.org/19581>.
-               (define start (now))
-               (let loop ((elapsed 0))
-                 (when (> n elapsed)
-                   (sleep (- n elapsed))
-                   (loop (- (now) start)))))
-
-             (define lset= (@ (srfi srfi-1) lset=))
-
-             (display "sending all processes the TERM signal\n")
-
-             (if (null? omitted-pids)
-                 (begin
-                   ;; Easy: terminate all of them.
-                   (kill -1 SIGTERM)
-                   (sleep* #$grace-delay)
-                   (kill -1 SIGKILL))
-                 (begin
-                   ;; Kill them all except OMITTED-PIDS.  XXX: We
-                   ;; would like to (kill -1 SIGSTOP) to get a fixed
-                   ;; list of processes, like 'killall5' does, but
-                   ;; that seems unreliable.
-                   (kill-except omitted-pids SIGTERM)
-                   (sleep* #$grace-delay)
-                   (kill-except omitted-pids SIGKILL)
-                   (delete-file #$%do-not-kill-file)))
-
-             (let wait ()
-               (let ((pids (processes)))
-                 (unless (lset= = pids (cons 1 omitted-pids))
-                   (format #t "waiting for process termination\
- (processes left: ~s)~%"
-                           pids)
-                   (sleep* 2)
-                   (wait))))
+  (service user-processes-service-type
+           (list file-systems grace-delay)))
 
-             (display "all processes have been terminated\n")
-             #f))
-   (respawn? #f)))
+
+;;;
+;;; Console & co.
+;;;
+
+(define host-name-service-type
+  (dmd-service-type
+   (lambda (name)
+     (dmd-service
+      (documentation "Initialize the machine's host name.")
+      (provision '(host-name))
+      (start #~(lambda _
+                 (sethostname #$name)))
+      (respawn? #f)))))
 
 (define (host-name-service name)
   "Return a service that sets the host name to @var{name}."
-  (service
-   (documentation "Initialize the machine's host name.")
-   (provision '(host-name))
-   (start #~(lambda _
-              (sethostname #$name)))
-   (respawn? #f)))
+  (service host-name-service-type name))
 
 (define (unicode-start tty)
   "Return a gexp to start Unicode support on @var{tty}."
@@ -310,15 +367,43 @@ stopped before 'kill' is called."
           (else
            (zero? (cdr (waitpid pid))))))))
 
+(define console-keymap-service-type
+  (dmd-service-type
+   (lambda (file)
+     (dmd-service
+      (documentation (string-append "Load console keymap (loadkeys)."))
+      (provision '(console-keymap))
+      (start #~(lambda _
+                 (zero? (system* (string-append #$kbd "/bin/loadkeys")
+                                 #$file))))
+      (respawn? #f)))))
+
 (define (console-keymap-service file)
   "Return a service to load console keymap from @var{file}."
-  (service
-   (documentation (string-append "Load console keymap (loadkeys)."))
-   (provision '(console-keymap))
-   (start #~(lambda _
-              (zero? (system* (string-append #$kbd "/bin/loadkeys")
-                              #$file))))
-   (respawn? #f)))
+  (service console-keymap-service-type file))
+
+(define console-font-service-type
+  (dmd-service-type
+   (match-lambda
+     ((tty font)
+      (let ((device (string-append "/dev/" tty)))
+        (dmd-service
+         (documentation "Load a Unicode console font.")
+         (provision (list (symbol-append 'console-font-
+                                         (string->symbol tty))))
+
+         ;; Start after mingetty has been started on TTY, otherwise the settings
+         ;; are ignored.
+         (requirement (list (symbol-append 'term-
+                                           (string->symbol tty))))
+
+         (start #~(lambda _
+                    (and #$(unicode-start device)
+                         (zero?
+                          (system* (string-append #$kbd "/bin/setfont")
+                                   "-C" #$device #$font)))))
+         (stop #~(const #t))
+         (respawn? #f)))))))
 
 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
   "Return a service that sets up Unicode support in @var{tty} and loads
@@ -326,24 +411,7 @@ stopped before 'kill' is called."
   ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
   ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
   ;; codepoints notably found in the UTF-8 manual.
-  (let ((device (string-append "/dev/" tty)))
-    (service
-     (documentation "Load a Unicode console font.")
-     (provision (list (symbol-append 'console-font-
-                                     (string->symbol tty))))
-
-     ;; Start after mingetty has been started on TTY, otherwise the
-     ;; settings are ignored.
-     (requirement (list (symbol-append 'term-
-                                       (string->symbol tty))))
-
-     (start #~(lambda _
-                (and #$(unicode-start device)
-                     (zero?
-                      (system* (string-append #$kbd "/bin/setfont")
-                               "-C" #$device #$font)))))
-     (stop #~(const #t))
-     (respawn? #f))))
+  (service console-font-service-type (list tty font)))
 
 (define-record-type* <mingetty-configuration>
   mingetty-configuration make-mingetty-configuration
@@ -365,43 +433,56 @@ stopped before 'kill' is called."
   (allow-empty-passwords? mingetty-configuration-allow-empty-passwords?
                           (default #t)))          ;Boolean
 
-(define* (mingetty-service config)
-  "Return a service to run mingetty according to @var{config}, a
-@code{<mingetty-configuration>} object, which specifies the tty to run, among
-other things."
-  (match config
+(define (mingetty-pam-service conf)
+  "Return the list of PAM service needed for CONF."
+  ;; Let 'login' be known to PAM.  All the mingetty services will have that
+  ;; PAM service, but that's fine because they're all identical and duplicates
+  ;; are removed.
+  (list (unix-pam-service "login"
+                          #:allow-empty-passwords?
+                          (mingetty-configuration-allow-empty-passwords? conf)
+                          #:motd
+                          (mingetty-configuration-motd conf))))
+
+(define mingetty-dmd-service
+  (match-lambda
     (($ <mingetty-configuration> mingetty tty motd auto-login login-program
                                  login-pause? allow-empty-passwords?)
-     (service
-      (documentation "Run mingetty on an tty.")
-      (provision (list (symbol-append 'term- (string->symbol tty))))
-
-      ;; Since the login prompt shows the host name, wait for the 'host-name'
-      ;; service to be done.  Also wait for udev essentially so that the tty
-      ;; text is not lost in the middle of kernel messages (XXX).
-      (requirement '(user-processes host-name udev))
-
-      (start  #~(make-forkexec-constructor
-                 (list (string-append #$mingetty "/sbin/mingetty")
-                       "--noclear" #$tty
-                       #$@(if auto-login
-                              #~("--autologin" #$auto-login)
-                              #~())
-                       #$@(if login-program
-                              #~("--loginprog" #$login-program)
-                              #~())
-                       #$@(if login-pause?
-                              #~("--loginpause")
-                              #~()))))
-      (stop   #~(make-kill-destructor))
-
-      (pam-services
-       ;; Let 'login' be known to PAM.  All the mingetty services will have
-       ;; that PAM service, but that's fine because they're all identical and
-       ;; duplicates are removed.
-       (list (unix-pam-service "login"
-                               #:allow-empty-passwords? allow-empty-passwords?
-                               #:motd motd)))))))
+     (list
+      (dmd-service
+       (documentation "Run mingetty on an tty.")
+       (provision (list (symbol-append 'term- (string->symbol tty))))
+
+       ;; Since the login prompt shows the host name, wait for the 'host-name'
+       ;; service to be done.  Also wait for udev essentially so that the tty
+       ;; text is not lost in the middle of kernel messages (XXX).
+       (requirement '(user-processes host-name udev))
+
+       (start  #~(make-forkexec-constructor
+                  (list (string-append #$mingetty "/sbin/mingetty")
+                        "--noclear" #$tty
+                        #$@(if auto-login
+                               #~("--autologin" #$auto-login)
+                               #~())
+                        #$@(if login-program
+                               #~("--loginprog" #$login-program)
+                               #~())
+                        #$@(if login-pause?
+                               #~("--loginpause")
+                               #~()))))
+       (stop   #~(make-kill-destructor)))))))
+
+(define mingetty-service-type
+  (service-type (name 'mingetty)
+                (extensions (list (service-extension dmd-root-service-type
+                                                     mingetty-dmd-service)
+                                  (service-extension pam-root-service-type
+                                                     mingetty-pam-service)))))
+
+(define* (mingetty-service config)
+  "Return a service to run mingetty according to @var{config}, which specifies
+the tty to run, among other things."
+  (service mingetty-service-type config))
 
 (define-record-type* <nscd-configuration> nscd-configuration
   make-nscd-configuration
@@ -506,38 +587,72 @@ other things."
                                 (string-concatenate
                                  (map cache->config caches)))))))
 
+(define (nscd-dmd-service config)
+  "Return a dmd service for CONFIG, an <nscd-configuration> object."
+  (let ((nscd.conf     (nscd.conf-file config))
+        (name-services (nscd-configuration-name-services config)))
+    (list (dmd-service
+           (documentation "Run libc's name service cache daemon (nscd).")
+           (provision '(nscd))
+           (requirement '(user-processes))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$(nscd-configuration-glibc config)
+                                          "/sbin/nscd")
+                           "-f" #$nscd.conf "--foreground")
+
+                     #:environment-variables
+                     (list (string-append "LD_LIBRARY_PATH="
+                                          (string-join
+                                           (map (lambda (dir)
+                                                  (string-append dir "/lib"))
+                                                (list #$@name-services))
+                                           ":")))))
+           (stop #~(make-kill-destructor))
+
+           (respawn? #f)))))
+
+(define nscd-activation
+  ;; Actions to take before starting nscd.
+  #~(begin
+      (use-modules (guix build utils))
+      (mkdir-p "/var/run/nscd")
+      (mkdir-p "/var/db/nscd")))                  ;for the persistent cache
+
+(define nscd-service-type
+  (service-type (name 'nscd)
+                (extensions
+                 (list (service-extension activation-service-type
+                                          (const nscd-activation))
+                       (service-extension dmd-root-service-type
+                                          nscd-dmd-service)))
+
+                ;; This can be extended by providing additional name services
+                ;; such as nss-mdns.
+                (compose concatenate)
+                (extend (lambda (config name-services)
+                          (nscd-configuration
+                           (inherit config)
+                           (name-services (append
+                                           (nscd-configuration-name-services config)
+                                           name-services)))))))
+
 (define* (nscd-service #:optional (config %nscd-default-configuration))
   "Return a service that runs libc's name service cache daemon (nscd) with the
 given @var{config}---an @code{<nscd-configuration>} object.  @xref{Name
 Service Switch}, for an example."
-  (let ((nscd.conf (nscd.conf-file config)))
-    (service
-     (documentation "Run libc's name service cache daemon (nscd).")
-     (provision '(nscd))
-     (requirement '(user-processes))
-
-     (activate #~(begin
-                   (use-modules (guix build utils))
-                   (mkdir-p "/var/run/nscd")
-                   (mkdir-p "/var/db/nscd")))     ;for the persistent cache
-
-     (start #~(make-forkexec-constructor
-               (list (string-append #$(nscd-configuration-glibc config)
-                                    "/sbin/nscd")
-                     "-f" #$nscd.conf "--foreground")
-
-               #:environment-variables
-               (list (string-append "LD_LIBRARY_PATH="
-                                    (string-join
-                                     (map (lambda (dir)
-                                            (string-append dir "/lib"))
-                                          (list
-                                           #$@(nscd-configuration-name-services
-                                               config)))
-                                     ":")))))
-     (stop #~(make-kill-destructor))
-
-     (respawn? #f))))
+  (service nscd-service-type config))
+
+(define syslog-service-type
+  (dmd-service-type
+   (lambda (config-file)
+     (dmd-service
+      (documentation "Run the syslog daemon (syslogd).")
+      (provision '(syslogd))
+      (requirement '(user-processes))
+      (start #~(make-forkexec-constructor
+                (list (string-append #$inetutils "/libexec/syslogd")
+                      "--no-detach" "--rcfile" #$config-file)))
+      (stop #~(make-kill-destructor))))))
 
 ;; Snippet adapted from the GNU inetutils manual.
 (define %default-syslog.conf
@@ -561,18 +676,12 @@ Service Switch}, for an example."
      # Log all the mail messages in one place.
      mail.*                                  /var/log/maillog
 "))
+
 (define* (syslog-service #:key (config-file %default-syslog.conf))
   "Return a service that runs @code{syslogd}.
 If configuration file name @var{config-file} is not specified, use some
 reasonable default settings."
-  (service
-   (documentation "Run the syslog daemon (syslogd).")
-   (provision '(syslogd))
-   (requirement '(user-processes))
-   (start #~(make-forkexec-constructor
-             (list (string-append #$inetutils "/libexec/syslogd")
-                   "--no-detach" "--rcfile" #$config-file)))
-   (stop #~(make-kill-destructor))))
+  (service syslog-service-type config-file))
 
 (define* (guix-build-accounts count #:key
                               (group "guixbuild")
@@ -621,61 +730,104 @@ GUIX."
                (format (current-error-port) "warning: \
 failed to register hydra.gnu.org public key: ~a~%" status))))))))
 
-(define* (guix-service #:key (guix guix) (builder-group "guixbuild")
-                       (build-accounts 10) (authorize-hydra-key? #t)
-                       (use-substitutes? #t)
-                       (extra-options '())
-                       (lsof lsof) (lsh lsh))
-  "Return a service that runs the build daemon from @var{guix}, and has
-@var{build-accounts} user accounts available under @var{builder-group}.
-
-When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key
-provided by @var{guix} is authorized upon activation, meaning that substitutes
-from @code{hydra.gnu.org} are used by default.
-
-If @var{use-substitutes?} is false, the daemon is run with
-@option{--no-substitutes} (@pxref{Invoking guix-daemon,
-@option{--no-substitutes}}).
-
-Finally, @var{extra-options} is a list of additional command-line options
-passed to @command{guix-daemon}."
-  (define activate
-    ;; Assume that the store has BUILDER-GROUP as its group.  We could
-    ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
-    ;; chown leads to an entire copy of the tree, which is a bad idea.
-
-    ;; Optionally authorize hydra.gnu.org's key.
-    (and authorize-hydra-key?
-         (hydra-key-authorization guix)))
-
-  (service
-   (documentation "Run the Guix daemon.")
-   (provision '(guix-daemon))
-   (requirement '(user-processes))
-   (start
-    #~(make-forkexec-constructor
-       (list (string-append #$guix "/bin/guix-daemon")
-             "--build-users-group" #$builder-group
-             #$@(if use-substitutes?
-                    '()
-                    '("--no-substitutes"))
-             #$@extra-options)
-
-       ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
-       ;; daemon's $PATH.
-       #:environment-variables
-       (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
-   (stop #~(make-kill-destructor))
-   (user-accounts (guix-build-accounts build-accounts
-                                       #:group builder-group))
-   (user-groups (list (user-group
-                       (name builder-group)
-                       (system? #t)
-
-                       ;; Use a fixed GID so that we can create the
-                       ;; store with the right owner.
-                       (id 30000))))
-   (activate activate)))
+(define-record-type* <guix-configuration>
+  guix-configuration make-guix-configuration
+  guix-configuration?
+  (guix             guix-configuration-guix       ;<package>
+                    (default guix))
+  (build-group      guix-configuration-build-group ;string
+                    (default "guixbuild"))
+  (build-accounts   guix-configuration-build-accounts ;integer
+                    (default 10))
+  (authorize-key?   guix-configuration-authorize-key? ;Boolean
+                    (default #t))
+  (use-substitutes? guix-configuration-use-substitutes? ;Boolean
+                    (default #t))
+  (extra-options    guix-configuration-extra-options ;list of strings
+                    (default '()))
+  (lsof             guix-configuration-lsof       ;<package>
+                    (default lsof))
+  (lsh              guix-configuration-lsh        ;<package>
+                    (default lsh)))
+
+(define %default-guix-configuration
+  (guix-configuration))
+
+(define (guix-dmd-service config)
+  "Return a <dmd-service> for the Guix daemon service with CONFIG."
+  (match config
+    (($ <guix-configuration> guix build-group build-accounts authorize-key?
+                             use-substitutes? extra-options lsof lsh)
+     (list (dmd-service
+            (documentation "Run the Guix daemon.")
+            (provision '(guix-daemon))
+            (requirement '(user-processes))
+            (start
+             #~(make-forkexec-constructor
+                (list (string-append #$guix "/bin/guix-daemon")
+                      "--build-users-group" #$build-group
+                      #$@(if use-substitutes?
+                             '()
+                             '("--no-substitutes"))
+                      #$@extra-options)
+
+                ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
+                ;; daemon's $PATH.
+                #:environment-variables
+                (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
+            (stop #~(make-kill-destructor)))))))
+
+(define (guix-accounts config)
+  "Return the user accounts and user groups for CONFIG."
+  (match config
+    (($ <guix-configuration> _ build-group build-accounts)
+     (cons (user-group
+            (name build-group)
+            (system? #t)
+
+            ;; Use a fixed GID so that we can create the store with the right
+            ;; owner.
+            (id 30000))
+           (guix-build-accounts build-accounts
+                                #:group build-group)))))
+
+(define (guix-activation config)
+  "Return the activation gexp for CONFIG."
+  (match config
+    (($ <guix-configuration> guix build-group build-accounts authorize-key?)
+     ;; Assume that the store has BUILD-GROUP as its group.  We could
+     ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
+     ;; chown leads to an entire copy of the tree, which is a bad idea.
+
+     ;; Optionally authorize hydra.gnu.org's key.
+     (and authorize-key?
+          (hydra-key-authorization guix)))))
+
+(define guix-service-type
+  (service-type
+   (name 'guix)
+   (extensions
+    (list (service-extension dmd-root-service-type guix-dmd-service)
+          (service-extension account-service-type guix-accounts)
+          (service-extension activation-service-type guix-activation)))))
+
+(define* (guix-service #:optional (config %default-guix-configuration))
+  "Return a service that runs the Guix build daemon according to
+@var{config}."
+  (service guix-service-type config))
+
+
+;;;
+;;; Udev.
+;;;
+
+(define-record-type* <udev-configuration>
+  udev-configuration make-udev-configuration
+  udev-configuration?
+  (udev   udev-configuration-udev                 ;<package>
+          (default udev))
+  (rules  udev-configuration-rules                ;list of <package>
+          (default '())))
 
 (define (udev-rules-union packages)
   "Return the union of the @code{lib/udev/rules.d} directories found in each
@@ -727,118 +879,150 @@ item of @var{packages}."
 KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port))))
                  #:modules '((guix build utils))))
 
+(define udev-dmd-service
+  ;; Return a <dmd-service> for UDEV with RULES.
+  (match-lambda
+    (($ <udev-configuration> udev rules)
+     (let* ((rules     (udev-rules-union (cons* udev (kvm-udev-rule) rules)))
+            (udev.conf (computed-file "udev.conf"
+                                      #~(call-with-output-file #$output
+                                          (lambda (port)
+                                            (format port
+                                                    "udev_rules=\"~a/lib/udev/rules.d\"\n"
+                                                    #$rules))))))
+       (list
+        (dmd-service
+         (provision '(udev))
+
+         ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
+         ;; be added: see
+         ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
+         (requirement '(root-file-system))
+
+         (documentation "Populate the /dev directory, dynamically.")
+         (start #~(lambda ()
+                    (define find
+                      (@ (srfi srfi-1) find))
+
+                    (define udevd
+                      ;; Choose the right 'udevd'.
+                      (find file-exists?
+                            (map (lambda (suffix)
+                                   (string-append #$udev suffix))
+                                 '("/libexec/udev/udevd" ;udev
+                                   "/sbin/udevd"))))     ;eudev
+
+                    (define (wait-for-udevd)
+                      ;; Wait until someone's listening on udevd's control
+                      ;; socket.
+                      (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
+                        (let try ()
+                          (catch 'system-error
+                            (lambda ()
+                              (connect sock PF_UNIX "/run/udev/control")
+                              (close-port sock))
+                            (lambda args
+                              (format #t "waiting for udevd...~%")
+                              (usleep 500000)
+                              (try))))))
+
+                    ;; Allow udev to find the modules.
+                    (setenv "LINUX_MODULE_DIRECTORY"
+                            "/run/booted-system/kernel/lib/modules")
+
+                    ;; The first one is for udev, the second one for eudev.
+                    (setenv "UDEV_CONFIG_FILE" #$udev.conf)
+                    (setenv "EUDEV_RULES_DIRECTORY"
+                            (string-append #$rules "/lib/udev/rules.d"))
+
+                    (let ((pid (primitive-fork)))
+                      (case pid
+                        ((0)
+                         (exec-command (list udevd)))
+                        (else
+                         ;; Wait until udevd is up and running.  This
+                         ;; appears to be needed so that the events
+                         ;; triggered below are actually handled.
+                         (wait-for-udevd)
+
+                         ;; Trigger device node creation.
+                         (system* (string-append #$udev "/bin/udevadm")
+                                  "trigger" "--action=add")
+
+                         ;; Wait for things to settle down.
+                         (system* (string-append #$udev "/bin/udevadm")
+                                  "settle")
+                         pid)))))
+         (stop #~(make-kill-destructor))
+
+         ;; When halting the system, 'udev' is actually killed by
+         ;; 'user-processes', i.e., before its own 'stop' method was called.
+         ;; Thus, make sure it is not respawned.
+         (respawn? #f)))))))
+
+(define udev-service-type
+  (service-type (name 'udev)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          udev-dmd-service)))
+
+                (compose concatenate)           ;concatenate the list of rules
+                (extend (lambda (config rules)
+                          (match config
+                            (($ <udev-configuration> udev initial-rules)
+                             (udev-configuration
+                              (udev udev)
+                              (rules (append initial-rules rules)))))))))
+
 (define* (udev-service #:key (udev eudev) (rules '()))
   "Run @var{udev}, which populates the @file{/dev} directory dynamically.  Get
 extra rules from the packages listed in @var{rules}."
-  (let* ((rules     (udev-rules-union (cons* udev
-                                             (kvm-udev-rule)
-                                             rules)))
-         (udev.conf (computed-file "udev.conf"
-                                   #~(call-with-output-file #$output
-                                       (lambda (port)
-                                         (format port
-                                                 "udev_rules=\"~a/lib/udev/rules.d\"\n"
-                                                 #$rules))))))
-    (service
-     (provision '(udev))
-
-     ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
-     ;; be added: see
-     ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
-     (requirement '(root-file-system))
-
-     (documentation "Populate the /dev directory, dynamically.")
-     (start #~(lambda ()
-                (define find
-                  (@ (srfi srfi-1) find))
-
-                (define udevd
-                  ;; Choose the right 'udevd'.
-                  (find file-exists?
-                        (map (lambda (suffix)
-                               (string-append #$udev suffix))
-                             '("/libexec/udev/udevd" ;udev
-                               "/sbin/udevd"))))     ;eudev
-
-                (define (wait-for-udevd)
-                  ;; Wait until someone's listening on udevd's control
-                  ;; socket.
-                  (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
-                    (let try ()
-                      (catch 'system-error
-                        (lambda ()
-                          (connect sock PF_UNIX "/run/udev/control")
-                          (close-port sock))
-                        (lambda args
-                          (format #t "waiting for udevd...~%")
-                          (usleep 500000)
-                          (try))))))
-
-                ;; Allow udev to find the modules.
-                (setenv "LINUX_MODULE_DIRECTORY"
-                        "/run/booted-system/kernel/lib/modules")
-
-                ;; The first one is for udev, the second one for eudev.
-                (setenv "UDEV_CONFIG_FILE" #$udev.conf)
-                (setenv "EUDEV_RULES_DIRECTORY"
-                        (string-append #$rules "/lib/udev/rules.d"))
-
-                (let ((pid (primitive-fork)))
-                  (case pid
-                    ((0)
-                     (exec-command (list udevd)))
-                    (else
-                     ;; Wait until udevd is up and running.  This
-                     ;; appears to be needed so that the events
-                     ;; triggered below are actually handled.
-                     (wait-for-udevd)
-
-                     ;; Trigger device node creation.
-                     (system* (string-append #$udev "/bin/udevadm")
-                              "trigger" "--action=add")
-
-                     ;; Wait for things to settle down.
-                     (system* (string-append #$udev "/bin/udevadm")
-                              "settle")
-                     pid)))))
-     (stop #~(make-kill-destructor))
-
-     ;; When halting the system, 'udev' is actually killed by
-     ;; 'user-processes', i.e., before its own 'stop' method was
-     ;; called.  Thus, make sure it is not respawned.
-     (respawn? #f))))
+  (service udev-service-type
+           (udev-configuration (udev udev) (rules rules))))
+
+(define device-mapping-service-type
+  (dmd-service-type
+   (match-lambda
+     ((target open close)
+      (dmd-service
+       (provision (list (symbol-append 'device-mapping- (string->symbol target))))
+       (requirement '(udev))
+       (documentation "Map a device node using Linux's device mapper.")
+       (start #~(lambda () #$open))
+       (stop #~(lambda _ (not #$close)))
+       (respawn? #f))))))
 
 (define (device-mapping-service target open close)
   "Return a service that maps device @var{target}, a string such as
 @code{\"home\"} (meaning @code{/dev/mapper/home}).  Evaluate @var{open}, a
 gexp, to open it, and evaluate @var{close} to close it."
-  (service
-   (provision (list (symbol-append 'device-mapping- (string->symbol target))))
-   (requirement '(udev))
-   (documentation "Map a device node using Linux's device mapper.")
-   (start #~(lambda () #$open))
-   (stop #~(lambda _ (not #$close)))
-   (respawn? #f)))
+  (service device-mapping-service-type
+           (list target open close)))
+
+(define swap-service-type
+  (dmd-service-type
+   (lambda (device)
+     (define requirement
+       (if (string-prefix? "/dev/mapper/" device)
+           (list (symbol-append 'device-mapping-
+                                (string->symbol (basename device))))
+           '()))
+
+     (dmd-service
+      (provision (list (symbol-append 'swap- (string->symbol device))))
+      (requirement `(udev ,@requirement))
+      (documentation "Enable the given swap device.")
+      (start #~(lambda ()
+                 (restart-on-EINTR (swapon #$device))
+                 #t))
+      (stop #~(lambda _
+                (restart-on-EINTR (swapoff #$device))
+                #f))
+      (respawn? #f)))))
 
 (define (swap-service device)
   "Return a service that uses @var{device} as a swap device."
-  (define requirement
-    (if (string-prefix? "/dev/mapper/" device)
-        (list (symbol-append 'device-mapping-
-                             (string->symbol (basename device))))
-        '()))
-
-  (service
-   (provision (list (symbol-append 'swap- (string->symbol device))))
-   (requirement `(udev ,@requirement))
-   (documentation "Enable the given swap device.")
-   (start #~(lambda ()
-              (restart-on-EINTR (swapon #$device))
-              #t))
-   (stop #~(lambda _
-             (restart-on-EINTR (swapoff #$device))
-             #f))
-   (respawn? #f)))
+  (service swap-service-type device))
 
 (define %base-services
   ;; Convenience variable holding the basic services.
@@ -873,9 +1057,6 @@ This is the GNU operating system, welcome!\n\n")))
           ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
           ;; used, so enable them by default.  The FUSE and ALSA rules are
           ;; less critical, but handy.
-          ;;
-          ;; XXX Keep this in sync with the 'udev-service' call in
-          ;; %desktop-services.
           (udev-service #:rules (list lvm2 fuse alsa-utils crda)))))
 
 ;;; base.scm ends here