guix-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

13/13: PRELIM: services: Introduce extensible abstract services.


From: Ludovic Courtès
Subject: 13/13: PRELIM: services: Introduce extensible abstract services.
Date: Wed, 23 Sep 2015 20:55:21 +0000

civodul pushed a commit to branch wip-service-refactor
in repository guix.

commit 2f719e2df8f339a1b149f417c8979d252f2917ab
Author: Ludovic Courtès <address@hidden>
Date:   Thu Sep 17 23:44:26 2015 +0200

    PRELIM: services: Introduce extensible abstract services.
    
    Works well enough to run:
    
      guix system vm gnu/system/examples/desktop.tmpl
    
    and to boot the system.
---
 doc/guix.texi               |    6 +-
 gnu-system.am               |    1 +
 gnu/services.scm            |  365 +++++++++++++++++--
 gnu/services/avahi.scm      |  114 ++++--
 gnu/services/base.scm       |  843 ++++++++++++++++++++++++++-----------------
 gnu/services/databases.scm  |  139 ++++---
 gnu/services/dbus.scm       |  174 +++++++++
 gnu/services/desktop.scm    |  569 ++++++++++++++---------------
 gnu/services/dmd.scm        |   73 ++++-
 gnu/services/networking.scm |  531 +++++++++++++++++-----------
 gnu/services/ssh.scm        |  165 ++++++---
 gnu/services/xorg.scm       |  134 +++++---
 gnu/system.scm              |  361 ++++---------------
 gnu/system/install.scm      |   54 ++--
 gnu/system/linux.scm        |   31 ++-
 gnu/system/shadow.scm       |  106 +++++-
 16 files changed, 2254 insertions(+), 1412 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 4bfc3d5..24d241e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6126,8 +6126,7 @@ Reference, @code{services}}).
 The actual service definitions provided by @code{(gnu services desktop)}
 are described below.
 
address@hidden {Scheme Procedure} dbus-service @var{services} @
-                         [#:dbus @var{dbus}]
address@hidden {Scheme Procedure} dbus-service [#:dbus @var{dbus}] [#:services 
'()]
 Return a service that runs the ``system bus'', using @var{dbus}, with
 support for @var{services}.
 
@@ -6141,8 +6140,7 @@ and policy files.  For example, to allow avahi-daemon to 
use the system bus,
 @var{services} must be equal to @code{(list avahi)}.
 @end deffn
 
address@hidden {Scheme Procedure} elogind-service @
-                         [#:elogind @var{elogind}] [#:config @var{config}]
address@hidden {Scheme Procedure} elogind-service [#:config @var{config}]
 Return a service that runs the @code{elogind} login and
 seat management daemon.  @uref{https://github.com/andywingo/elogind,
 Elogind} exposes a D-Bus interface that can be used to know which users
diff --git a/gnu-system.am b/gnu-system.am
index 2d26131..2ec1262 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -347,6 +347,7 @@ GNU_SYSTEM_MODULES =                                \
   gnu/services/avahi.scm                       \
   gnu/services/base.scm                                \
   gnu/services/databases.scm                   \
+  gnu/services/dbus.scm                                \
   gnu/services/desktop.scm                     \
   gnu/services/dmd.scm                         \
   gnu/services/lirc.scm                                \
diff --git a/gnu/services.scm b/gnu/services.scm
index 43e51b9..2d8c47f 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,49 +18,334 @@
 
 (define-module (gnu services)
   #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix store)
   #:use-module (guix records)
-  #:export (service?
+  #:use-module (guix sets)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages bash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:export (service-extension
+            service-extension?
+
+            service-type
+            service-type?
+
             service
-            service-documentation
-            service-provision
-            service-requirement
-            service-respawn?
-            service-start
-            service-stop
-            service-auto-start?
-            service-activate
-            service-user-accounts
-            service-user-groups
-            service-pam-services))
-
-;;; Commentary:
+            service?
+            service-kind
+            service-parameters
+
+            fold-services
+
+            boot-service-type
+            activation-service-type
+            etc-service-type
+            etc-directory
+
+            %boot-service
+            %activation-service
+            etc-service
+
+            file-union))                      ;XXX: for lack of a better place
+
+
+(define-record-type <service-extension>
+  (service-extension target compute)
+  service-extension?
+  (target  service-extension-target)              ;<service-type>
+  (compute service-extension-compute))            ;params -> params
+
+(define-record-type* <service-type> service-type make-service-type
+  service-type?
+  (name       service-type-name)                 ;symbol (for debugging)
+
+  ;; Things extended by services of this type.
+  (extensions service-type-extensions            ;list of <service-extensions>
+              (default '()))
+
+  ;; Given a list of extensions, "compose" them.
+  (compose    service-type-compose                ;list of Any -> Any
+              (default #f))
+
+  ;; Extend the services' own parameters with the extension composition.
+  (extend     service-type-extend                 ;list of Any -> parameters
+              (default #f)))
+
+(define (write-service-type type port)
+  (format port "#<service-type ~a ~a>"
+          (service-type-name type)
+          (number->string (object-address type) 16)))
+
+(set-record-type-printer! <service-type> write-service-type)
+
+(define-record-type* <service> service make-service
+  service?
+  (type       service-kind)
+  (parameters service-parameters (default #f)))
+
+
+
+
 ;;;
-;;; System services as cajoled by dmd.
+;;; Core services.
 ;;;
-;;; Code:
 
-(define-record-type* <service>
-  service make-service
-  service?
-  (documentation service-documentation            ; string
-                 (default "[No documentation.]"))
-  (provision     service-provision)               ; list of symbols
-  (requirement   service-requirement              ; list of symbols
-                 (default '()))
-  (respawn?      service-respawn?                 ; Boolean
-                 (default #t))
-  (start         service-start)                   ; g-expression (procedure)
-  (stop          service-stop                     ; g-expression (procedure)
-                 (default #~(const #f)))
-  (auto-start?   service-auto-start?              ; Boolean
-                 (default #t))
-  (user-accounts service-user-accounts            ; list of <user-account>
-                 (default '()))
-  (user-groups   service-user-groups              ; list of <user-groups>
-                 (default '()))
-  (pam-services  service-pam-services             ; list of <pam-service>
-                 (default '()))
-  (activate      service-activate                 ; gexp
-                 (default #f)))
+(define (compute-boot-script mexps)
+  (mlet %store-monad ((gexps (sequence %store-monad mexps)))
+    (gexp->file "boot"
+                #~(begin
+                    (use-modules (guix build utils))
+
+                    ;; Clean out /tmp and /var/run.
+                    ;;
+                    ;; XXX This needs to happen before service activations, so
+                    ;; it has to be here, but this also implicitly assumes
+                    ;; that /tmp and /var/run are on the root partition.
+                    (false-if-exception (delete-file-recursively "/tmp"))
+                    (false-if-exception (delete-file-recursively "/var/run"))
+                    (false-if-exception (mkdir "/tmp"))
+                    (false-if-exception (chmod "/tmp" #o1777))
+                    (false-if-exception (mkdir "/var/run"))
+                    (false-if-exception (chmod "/var/run" #o755))
+
+                    ;; Activate the system and spawn dmd.
+                    address@hidden))))
+
+(define (second-argument a b) b)
+
+(define boot-service-type
+  ;; The service of this type is extended by being passed gexps as monadic
+  ;; values.  It aggregates them in a single script, as a monadic value, which
+  ;; becomes its 'parameters'.
+  (service-type (name 'boot)
+                (compose compute-boot-script)
+                (extend second-argument)))
+
+(define %boot-service
+  ;; This is the ultimate service, the root of the service DAG.
+  (service (type boot-service-type)
+           (parameters #t)))
+
+(define* (file-union name files)                  ;FIXME: Factorize.
+  "Return a <computed-file> that builds a directory containing all of FILES.
+Each item in FILES must be a list where the first element is the file name to
+use in the new directory, and the second element is a gexp denoting the target
+file."
+  (computed-file name
+                 #~(begin
+                     (mkdir #$output)
+                     (chdir #$output)
+                     #$@(map (match-lambda
+                               ((target source)
+                                #~(symlink #$source #$target)))
+                             files))))
+
+(define (directory-union name things)
+  "Return a directory that is the union of THINGS."
+  (match things
+    ((one)
+     ;; Only one thing; return it.
+     one)
+    (_
+     (computed-file name
+                    #~(begin
+                        (use-modules (guix build union))
+                        (union-build #$output '#$things))
+                    #:modules '((guix build union))))))
+
+(define (modprobe-wrapper)
+  "Return a wrapper for the 'modprobe' command that knows where modules live.
+
+This wrapper is typically invoked by the Linux kernel ('call_modprobe', in
+kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment
+variable is not set---hence the need for this wrapper."
+  (let ((modprobe "/run/current-system/profile/bin/modprobe"))
+    (gexp->script "modprobe"
+                  #~(begin
+                      (setenv "LINUX_MODULE_DIRECTORY"
+                              "/run/booted-system/kernel/lib/modules")
+                      (apply execl #$modprobe
+                             (cons #$modprobe (cdr (command-line))))))))
+
+(define* (activation-script gexps
+                            ;; FIXME: Should be in <activation-parameters>.
+                            #:key container?
+                            (firmware '()))
+  "Return as a monadic value a file that runs GEXPS."
+  (define %modules
+    '((gnu build activation)
+      (gnu build linux-boot)
+      (gnu build linux-modules)
+      (gnu build file-systems)
+      (guix build utils)
+      (guix build syscalls)
+      (guix elf)))
+
+  (define (service-activations)
+    ;; Return the activation scripts for SERVICES.
+    (mapm %store-monad
+          (cut gexp->file "activate-service" <>)
+          gexps))
+
+  (mlet* %store-monad ((actions  (service-activations))
+                       (modules  (imported-modules %modules))
+                       (compiled (compiled-modules %modules))
+                       (modprobe (modprobe-wrapper))
+                       (firmware -> (directory-union
+                                     "firmware" firmware)))
+    (define setuid-progs
+      '())                                        ;FIXME
+
+    (gexp->file "activate"
+                #~(begin
+                    (eval-when (expand load eval)
+                      ;; Make sure 'use-modules' below succeeds.
+                      (set! %load-path (cons #$modules %load-path))
+                      (set! %load-compiled-path
+                        (cons #$compiled %load-compiled-path)))
+
+                    (use-modules (gnu build activation))
+
+                    ;; Make sure /bin/sh is valid and current.
+                    (activate-/bin/sh
+                     (string-append #$(canonical-package bash) "/bin/sh"))
+
+                    ;; Activate setuid programs.
+                    (activate-setuid-programs (list address@hidden))
+
+                    ;; Tell the kernel to use our 'modprobe' command.
+                    (activate-modprobe #$modprobe)
+
+                    ;; Tell the kernel where firmware is, unless we are
+                    ;; activating a container.
+                    #$@(if container?
+                           #~()
+                           ;; Tell the kernel where firmware is.
+                           #~((activate-firmware
+                               (string-append #$firmware "/lib/firmware"))
+                              ;; Let users debug their own processes!
+                              (activate-ptrace-attach)))
+
+                    ;; Run the services' activation snippets.
+                    ;; TODO: Use 'load-compiled'.
+                    (for-each primitive-load '#$actions)
+
+                    ;; Set up /run/current-system.
+                    (activate-current-system)))))
+
+(define (gexps->activation-gexp gexps)
+  "Return a gexp that runs the activation script containing GEXPS."
+  (mlet %store-monad ((script (activation-script gexps)))
+    (return #~(primitive-load #$script))))
+
+(define activation-service-type
+  (service-type (name 'activate)
+                (extensions
+                 (list (service-extension boot-service-type
+                                          gexps->activation-gexp)))
+                (compose append)
+                (extend second-argument)))
+
+(define %activation-service
+  (service (type activation-service-type)
+           (parameters #t)))                      ;list of gexps
+
+(define (etc-directory service)
+  "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
+  (files->etc-directory (service-parameters service)))
+
+(define (files->etc-directory files)
+  (file-union "etc" files))
+
+(define etc-service-type
+  (service-type (name 'etc)
+                (extensions
+                 (list
+                  (service-extension activation-service-type
+                                     (lambda (files)
+                                       (let ((etc
+                                              (files->etc-directory files)))
+                                         #~(activate-etc #$etc))))))
+                (compose concatenate)
+                (extend append)))
+
+(define (etc-service files)
+  "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES.
+FILES must be a list of name/file-like object pairs."
+  (service (type etc-service-type)
+           (parameters files)))                     ;list of name/file pairs
+
+
+;;;
+;;; Service folding.
+;;;
+
+(define (service-back-edges services)
+  "Return a procedure that, when passed a <service>, returns the list of
+<service> objects that depend on it."
+  (define (add-edges service edges)
+    (define (add-edge extension edges)
+      (let ((target-type (service-extension-target extension)))
+        (match (filter (lambda (service)
+                         (eq? (service-kind service) target-type))
+                       services)
+          ((target)
+           (vhash-consq target service edges))
+          (()
+           (error "no target service" service target-type))
+          (x
+           (error "more than one target service" x)))))
+
+    (fold add-edge edges (service-type-extensions (service-kind service))))
+
+  (let ((edges (fold add-edges vlist-null services)))
+    (lambda (node)
+      (reverse (vhash-foldq* cons '() node edges)))))
+
+(define* (fold-services services #:key (target-type boot-service-type))
+  "Fold SERVICES by propagating their extensions down to the root of type
+BOOT-SERVICE-TYPE; return the root service adjusted accordingly."
+  (define dependents
+    (service-back-edges services))
+
+  (define (matching-extension target)
+    (let ((target (service-kind target)))
+      (match-lambda
+        (($ <service-extension> type)
+         (eq? type target)))))
+
+  (define (apply-extension target)
+    (lambda (service)
+      (match (find (matching-extension target)
+                   (service-type-extensions (service-kind service)))
+        (($ <service-extension> _ compute)
+         (compute (service-parameters service))))))
+
+  (match (filter (lambda (service)
+                   (eq? (service-kind service) target-type))
+                 services)
+    ((sink)
+     (let loop ((sink sink))
+       (let* ((dependents (map loop (dependents sink)))
+              (extensions (map (apply-extension sink) dependents))
+              (extend     (service-type-extend (service-kind sink)))
+              (compose    (service-type-compose (service-kind sink)))
+              (params     (service-parameters sink)))
+         ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a
+         ;; different type than the elements of EXTENSIONS.
+         (if extend
+             (service (inherit sink)
+                      (parameters (extend params (compose extensions))))
+             sink))))
+    (()
+     (error "no target service" target-type))
+    (x
+     (error "more than one target service" x))))
 
 ;;; services.scm ends here.
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm
index 929ac2f..87b910e 100644
--- a/gnu/services/avahi.scm
+++ b/gnu/services/avahi.scm
@@ -18,10 +18,13 @@
 
 (define-module (gnu services avahi)
   #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu services dmd)
+  #:use-module (gnu services dbus)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages avahi)
   #:use-module (gnu packages admin)
-  #:use-module (guix store)
+  #:use-module (guix records)
   #:use-module (guix gexp)
   #:export (avahi-service))
 
@@ -32,12 +35,19 @@
 ;;;
 ;;; Code:
 
-(define* (configuration-file #:key host-name publish?
-                             ipv4? ipv6? wide-area? domains-to-browse)
-  "Return an avahi-daemon configuration file."
+(define-record-type† avahi-configuration
+  ;; TODO: Export.
+  (avahi avahi)
+  host-name publish? ipv4? ipv6? wide-area? domains-to-browse)
+
+(define* (configuration-file config)
+  "Return an avahi-daemon configuration file based on CONFIG, an
+<avahi-configuration>."
   (define (bool value)
     (if value "yes\n" "no\n"))
 
+  (define host-name (avahi-configuration-host-name config))
+
   (plain-file "avahi-daemon.conf"
               (string-append
                "[server]\n"
@@ -45,14 +55,63 @@
                    (string-append "host-name=" host-name "\n")
                    "")
 
-               "browse-domains=" (string-join domains-to-browse)
+               "browse-domains=" (string-join
+                                  (avahi-configuration-domains-to-browse
+                                   config))
                "\n"
-               "use-ipv4=" (bool ipv4?)
-               "use-ipv6=" (bool ipv6?)
+               "use-ipv4=" (bool (avahi-configuration-ipv4? config))
+               "use-ipv6=" (bool (avahi-configuration-ipv6? config))
                "[wide-area]\n"
-               "enable-wide-area=" (bool wide-area?)
+               "enable-wide-area=" (bool (avahi-configuration-wide-area? 
config))
                "[publish]\n"
-               "disable-publishing=" (bool (not publish?)))))
+               "disable-publishing="
+               (bool (not (avahi-configuration-publish? config))))))
+
+(define %avahi-accounts
+  ;; Account and group for the Avahi daemon.
+  (list (user-group (name "avahi") (system? #t))
+        (user-account
+         (name "avahi")
+         (group "avahi")
+         (system? #t)
+         (comment "Avahi daemon user")
+         (home-directory "/var/empty")
+         (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define %avahi-activation
+  ;; Activation gexp.
+  #~(begin
+      (use-modules (guix build utils))
+      (mkdir-p "/var/run/avahi-daemon")))
+
+(define (avahi-dmd-service config)
+  "Return a list of <dmd-service> for CONFIG."
+  (let ((config (configuration-file config))
+        (avahi  (avahi-configuration-avahi config)))
+    (list (dmd-service
+           (documentation "Run the Avahi mDNS/DNS-SD responder.")
+           (provision '(avahi-daemon))
+           (requirement '(dbus-system networking))
+
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$avahi "/sbin/avahi-daemon")
+                           "--syslog" "-f" #$config)))
+           (stop #~(make-kill-destructor))))))
+
+(define avahi-service-type
+  (service-type (name 'avahi)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          avahi-dmd-service)
+                       (service-extension dbus-root-service-type
+                                          (compose list
+                                                   avahi-configuration-avahi))
+                       (service-extension account-service-type
+                                          (const %avahi-accounts))
+                       (service-extension activation-service-type
+                                          (const %avahi-activation))
+                       (service-extension nscd-service-type
+                                          (const (list nss-mdns)))))))
 
 (define* (avahi-service #:key (avahi avahi)
                         host-name
@@ -75,36 +134,11 @@ When @var{wide-area?} is true, DNS-SD over unicast DNS is 
enabled.
 
 Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6
 sockets."
-  (let ((config (configuration-file #:host-name host-name
-                                    #:publish? publish?
-                                    #:ipv4? ipv4?
-                                    #:ipv6? ipv6?
-                                    #:wide-area? wide-area?
-                                    #:domains-to-browse
-                                    domains-to-browse)))
-    (service
-     (documentation "Run the Avahi mDNS/DNS-SD responder.")
-     (provision '(avahi-daemon))
-     (requirement '(dbus-system networking))
-
-     (start #~(make-forkexec-constructor
-               (list (string-append #$avahi "/sbin/avahi-daemon")
-                     "--syslog" "-f" #$config)))
-     (stop #~(make-kill-destructor))
-     (activate #~(begin
-                   (use-modules (guix build utils))
-                   (mkdir-p "/var/run/avahi-daemon")))
-
-     (user-groups (list (user-group
-                         (name "avahi")
-                         (system? #t))))
-     (user-accounts (list (user-account
-                           (name "avahi")
-                           (group "avahi")
-                           (system? #t)
-                           (comment "Avahi daemon user")
-                           (home-directory "/var/empty")
-                           (shell
-                            #~(string-append #$shadow "/sbin/nologin"))))))))
+  (service (type avahi-service-type)
+           (parameters (avahi-configuration
+                        (avahi avahi) (host-name host-name)
+                        (publish? publish?) (ipv4? ipv4?) (ipv6? ipv6?)
+                        (wide-area? wide-area?)
+                        (domains-to-browse domains-to-browse)))))
 
 ;;; avahi.scm ends here
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 7b68111..988e297 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,6 +67,7 @@
             nscd-cache
             nscd-cache?
 
+            nscd-service-type
             nscd-service
             syslog-service
             guix-service
@@ -76,13 +80,8 @@
 ;;;
 ;;; 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.)
-
-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,10 +115,81 @@ 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 '()))
+(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 (type root-file-system-service-type)))
+
+(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(?): Alternately this could be an extensible service that 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 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
@@ -127,170 +197,151 @@ 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))))
+  (service (type file-system-service-type)
+           (parameters 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 (type user-unmount-service-type)
+           (parameters 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))))
-
-             (display "all processes have been terminated\n")
-             #f))
-   (respawn? #f)))
+  (service (type user-processes-service-type)
+           (parameters (list file-systems grace-delay))))
+
+(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 (type host-name-service-type)
+           (parameters name)))
 
 (define (unicode-start tty)
   "Return a gexp to start Unicode support on @var{tty}."
@@ -310,15 +361,44 @@ 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 (type console-keymap-service-type)
+           (parameters 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 +406,8 @@ 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 (type console-font-service-type)
+           (parameters (list tty font))))
 
 (define-record-type* <mingetty-configuration>
   mingetty-configuration make-mingetty-configuration
@@ -363,42 +427,57 @@ stopped before 'kill' is called."
   (allow-empty-passwords? mingetty-configuration-allow-empty-passwords?
                           (default #t)))          ;Boolean
 
+(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> tty motd auto-login login-program
+                                 login-pause? allow-empty-passwords?)
+     (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."
-  (match config
-    (($ <mingetty-configuration> 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)))))))
+  (service (type mingetty-service-type)
+           (parameters config)))
 
 (define-record-type* <nscd-configuration> nscd-configuration
   make-nscd-configuration
@@ -503,38 +582,73 @@ the tty to run, among 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 address@hidden))
+                                           ":")))))
+           (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 (type nscd-service-type)
+           (parameters 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
@@ -558,18 +672,13 @@ 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 (type syslog-service-type)
+           (parameters config-file)))
 
 (define* (guix-build-accounts count #:key
                               (group "guixbuild")
@@ -618,61 +727,95 @@ 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
address@hidden 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
address@hidden (@pxref{Invoking guix-daemon,
address@hidden).
-
-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"))
-             address@hidden)
-
-       ;; 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"))
+                      address@hidden)
+
+                ;; 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
address@hidden"
+  (service (type guix-service-type)
+           (parameters config)))
 
 (define (udev-rules-union packages)
   "Return the union of the @code{lib/udev/rules.d} directories found in each
@@ -724,9 +867,21 @@ item of @var{packages}."
 KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port))))
                  #:modules '((guix build utils))))
 
-(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}."
+(define udev-service-type
+  (service-type (name 'udev)
+                (extensions
+                 (list (service-extension
+                        dmd-root-service-type
+                        (match-lambda
+                          ((udev rules)
+                           (list (udev-rules->dmd-service rules
+                                                          #:udev udev)))))))
+                (compose concatenate)           ;concatenate the list of rules
+                (extend (lambda (udev rules)
+                          (list udev rules)))))
+
+(define* (udev-rules->dmd-service rules #:key (udev eudev))
+  "Return a <dmd-service> for UDEV with RULES."
   (let* ((rules     (udev-rules-union (cons* udev
                                              (kvm-udev-rule)
                                              rules)))
@@ -736,7 +891,7 @@ extra rules from the packages listed in @var{rules}."
                                          (format port
                                                  
"udev_rules=\"~a/lib/udev/rules.d\"\n"
                                                  #$rules))))))
-    (service
+    (dmd-service
      (provision '(udev))
 
      ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
@@ -801,41 +956,60 @@ extra rules from the packages listed in @var{rules}."
      (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.
+     ;; 'user-processes', i.e., before its own 'stop' method was called.
+     ;; Thus, make sure it is not respawned.
      (respawn? #f))))
 
+(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}."
+  (service (type udev-service-type)
+           (parameters udev)))
+
+(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 (type device-mapping-service-type)
+           (parameters (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 (type swap-service-type)
+           (parameters device)))
 
 (define %base-services
   ;; Convenience variable holding the basic services.
@@ -870,9 +1044,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
diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm
index 20f8a69..fc3ec3c 100644
--- a/gnu/services/databases.scm
+++ b/gnu/services/databases.scm
@@ -19,12 +19,13 @@
 
 (define-module (gnu services databases)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages databases)
   #:use-module (guix records)
-  #:use-module (guix store)
   #:use-module (guix gexp)
+  #:use-module (ice-9 match)
   #:export (postgresql-service))
 
 ;;; Commentary:
@@ -33,6 +34,9 @@
 ;;;
 ;;; Code:
 
+(define-record-type† postgresql-configuration
+  (postgresql postgresql) config-file data-directory)
+
 (define %default-postgres-hba
   (plain-file "pg_hba.conf"
               "
@@ -49,6 +53,77 @@ host all     all     ::1/128         trust"))
                    "hba_file = '" %default-postgres-hba "'\n"
                    "ident_file = '" %default-postgres-ident "\n"))
 
+(define %postgresql-accounts
+  (list (user-group (name "postgres") (system? #t))
+        (user-account
+         (name "postgres")
+         (group "postgres")
+         (system? #t)
+         (comment "PostgreSQL server user")
+         (home-directory "/var/empty")
+         (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define postgresql-activation
+  (match-lambda
+    (($ <postgresql-configuration> postgresql config-file data-directory)
+     #~(begin
+         (use-modules (guix build utils)
+                      (ice-9 match))
+
+         (let ((user (getpwnam "postgres"))
+               (initdb (string-append #$postgresql "/bin/initdb")))
+           ;; Create db state directory.
+           (mkdir-p #$data-directory)
+           (chown #$data-directory (passwd:uid user) (passwd:gid user))
+
+           ;; Drop privileges and init state directory in a new
+           ;; process.  Wait for it to finish before proceeding.
+           (match (primitive-fork)
+             (0
+              ;; Exit with a non-zero status code if an exception is thrown.
+              (dynamic-wind
+                (const #t)
+                (lambda ()
+                  (setgid (passwd:gid user))
+                  (setuid (passwd:uid user))
+                  (primitive-exit (system* initdb "-D" #$data-directory)))
+                (lambda ()
+                  (primitive-exit 1))))
+             (pid (waitpid pid))))))))
+
+(define postgresql-dmd-service
+  (match-lambda
+    (($ <postgresql-configuration> postgresql config-file data-directory)
+     (let ((start-script
+            ;; Wrapper script that switches to the 'postgres' user before
+            ;; launching daemon.
+            (program-file "start-postgres"
+                          #~(let ((user (getpwnam "postgres"))
+                                  (postgres (string-append #$postgresql
+                                                           "/bin/postgres")))
+                              (setgid (passwd:gid user))
+                              (setuid (passwd:uid user))
+                              (system* postgres
+                                       (string-append "--config-file="
+                                                      #$config-file)
+                                       "-D" #$data-directory)))))
+       (dmd-service
+        (provision '(postgres))
+        (documentation "Run the PostgreSQL daemon.")
+        (requirement '(user-processes loopback))
+        (start #~(make-forkexec-constructor #$start-script))
+        (stop #~(make-kill-destructor)))))))
+
+(define postgresql-service-type
+  (service-type (name 'postgresql)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          postgresql-dmd-service)
+                       (service-extension activation-service-type
+                                          postgresql-activation)
+                       (service-extension account-service-type
+                                          (const %postgresql-accounts))))))
+
 (define* (postgresql-service #:key (postgresql postgresql)
                              (config-file %default-postgres-config)
                              (data-directory "/var/lib/postgresql/data"))
@@ -56,60 +131,8 @@ host        all     all     ::1/128         trust"))
 
 The PostgreSQL daemon loads its runtime configuration from @var{config-file}
 and stores the database cluster in @var{data-directory}."
-  ;; Wrapper script that switches to the 'postgres' user before launching
-  ;; daemon.
-  (define start-script
-    (program-file "start-postgres"
-                  #~(let ((user (getpwnam "postgres"))
-                          (postgres (string-append #$postgresql
-                                                   "/bin/postgres")))
-                      (setgid (passwd:gid user))
-                      (setuid (passwd:uid user))
-                      (system* postgres
-                               (string-append "--config-file=" #$config-file)
-                               "-D" #$data-directory))))
-
-  (define activate
-    #~(begin
-        (use-modules (guix build utils)
-                     (ice-9 match))
-
-        (let ((user (getpwnam "postgres"))
-              (initdb (string-append #$postgresql "/bin/initdb")))
-          ;; Create db state directory.
-          (mkdir-p #$data-directory)
-          (chown #$data-directory (passwd:uid user) (passwd:gid user))
-
-          ;; Drop privileges and init state directory in a new
-          ;; process.  Wait for it to finish before proceeding.
-          (match (primitive-fork)
-            (0
-             ;; Exit with a non-zero status code if an exception is thrown.
-             (dynamic-wind
-               (const #t)
-               (lambda ()
-                 (setgid (passwd:gid user))
-                 (setuid (passwd:uid user))
-                 (primitive-exit (system* initdb "-D" #$data-directory)))
-               (lambda ()
-                 (primitive-exit 1))))
-            (pid (waitpid pid))))))
-
-  (service
-   (provision '(postgres))
-   (documentation "Run the PostgreSQL daemon.")
-   (requirement '(user-processes loopback))
-   (start #~(make-forkexec-constructor #$start-script))
-   (stop #~(make-kill-destructor))
-   (activate activate)
-   (user-groups (list (user-group
-                       (name "postgres")
-                       (system? #t))))
-   (user-accounts (list (user-account
-                         (name "postgres")
-                         (group "postgres")
-                         (system? #t)
-                         (comment "PostgreSQL server user")
-                         (home-directory "/var/empty")
-                         (shell
-                          #~(string-append #$shadow "/sbin/nologin")))))))
+  (service (type postgresql-service-type)
+           (parameters (postgresql-configuration
+                        (postgresql postgresql)
+                        (config-file config-file)
+                        (data-directory data-directory)))))
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
new file mode 100644
index 0000000..6f86dc9
--- /dev/null
+++ b/gnu/services/dbus.scm
@@ -0,0 +1,174 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services dbus)
+  #:use-module (gnu services)
+  #:use-module (gnu services dmd)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu packages glib)
+  #:use-module (gnu packages admin)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:export (dbus-root-service-type
+            dbus-service))
+
+;;;
+;;; D-Bus.
+;;;
+
+(define-record-type† dbus-configuration
+  (dbus dbus)                                     ;<package>
+  (services '()))                                 ;list of <package>
+
+(define (dbus-configuration-directory dbus services)
+  "Return a configuration directory for @var{dbus} that includes the
address@hidden/dbus-1/system.d} directories of each package listed in
address@hidden"
+  (define build
+    #~(begin
+        (use-modules (sxml simple)
+                     (srfi srfi-1))
+
+        (define (services->sxml services)
+          ;; Return the SXML 'includedir' clauses for DIRS.
+          `(busconfig
+            ,@(append-map (lambda (dir)
+                            `((includedir
+                               ,(string-append dir "/etc/dbus-1/system.d"))
+                              (servicedir         ;for '.service' files
+                               ,(string-append dir "/share/dbus-1/services"))
+                              (servicedir       ;likewise, for auto-activation
+                               ,(string-append
+                                 dir
+                                 "/share/dbus-1/system-services"))))
+                          services)))
+
+        (mkdir #$output)
+        (copy-file (string-append #$dbus "/etc/dbus-1/system.conf")
+                   (string-append #$output "/system.conf"))
+
+        ;; The default 'system.conf' has an <includedir> clause for
+        ;; 'system.d', so create it.
+        (mkdir (string-append #$output "/system.d"))
+
+        ;; 'system-local.conf' is automatically included by the default
+        ;; 'system.conf', so this is where we stuff our own things.
+        (call-with-output-file (string-append #$output "/system-local.conf")
+          (lambda (port)
+            (sxml->xml (services->sxml (list address@hidden))
+                       port)))))
+
+  (computed-file "dbus-configuration" build))
+
+(define %dbus-accounts
+  ;; Accounts used by the system bus.
+  (list (user-group (name "messagebus") (system? #t))
+        (user-account
+         (name "messagebus")
+         (group "messagebus")
+         (system? #t)
+         (comment "D-Bus system bus user")
+         (home-directory "/var/run/dbus")
+         (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define (dbus-activation config)
+  "Return an activation gexp for D-Bus using @var{config}."
+  #~(begin
+      (use-modules (guix build utils))
+
+      (mkdir-p "/var/run/dbus")
+
+      (let ((user (getpwnam "messagebus")))
+        (chown "/var/run/dbus"
+               (passwd:uid user) (passwd:gid user)))
+
+      (unless (file-exists? "/etc/machine-id")
+        (format #t "creating /etc/machine-id...~%")
+        (let ((prog (string-append #$(dbus-configuration-dbus config)
+                                   "/bin/dbus-uuidgen")))
+          ;; XXX: We can't use 'system' because the initrd's
+          ;; guile system(3) only works when 'sh' is in $PATH.
+          (let ((pid (primitive-fork)))
+            (if (zero? pid)
+                (call-with-output-file "/etc/machine-id"
+                  (lambda (port)
+                    (close-fdes 1)
+                    (dup2 (port->fdes port) 1)
+                    (execl prog)))
+                (waitpid pid)))))))
+
+(define dbus-dmd-service
+  (match-lambda
+    (($ <dbus-configuration> dbus services)
+     (let ((conf (dbus-configuration-directory dbus services)))
+       (list (dmd-service
+              (documentation "Run the D-Bus system daemon.")
+              (provision '(dbus-system))
+              (requirement '(user-processes))
+              (start #~(make-forkexec-constructor
+                        (list (string-append #$dbus "/bin/dbus-daemon")
+                              "--nofork"
+                              (string-append "--config-file=" #$conf
+                                             "/system.conf"))))
+              (stop #~(make-kill-destructor))))))))
+
+(define dbus-root-service-type
+  (service-type (name 'dbus)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          dbus-dmd-service)
+                       (service-extension activation-service-type
+                                          dbus-activation)
+                       (service-extension account-service-type
+                                          (const %dbus-accounts))))
+
+                ;; Extensions consist of lists of packages (representing D-Bus
+                ;; services) that we just concatenate.
+                ;;
+                ;; FIXME: We need 'dbus-daemon-launch-helper' to be
+                ;; setuid-root for auto-activation to work.
+                (compose concatenate)
+
+                ;; The service's parameters field is extended by augmenting
+                ;; its <dbus-configuration> 'services' field.
+                (extend (lambda (config services)
+                          (dbus-configuration
+                           (inherit config)
+                           (services
+                            (append (dbus-configuration-services config)
+                                    services)))))))
+
+(define* (dbus-service #:key (dbus dbus) (services '()))
+  "Return a service that runs the \"system bus\", using @var{dbus}, with
+support for @var{services}.
+
address@hidden://dbus.freedesktop.org/, D-Bus} is an inter-process communication
+facility.  Its system bus is used to allow system services to communicate and
+be notified of system-wide events.
+
address@hidden must be a list of packages that provide an
address@hidden/dbus-1/system.d} directory containing additional D-Bus 
configuration
+and policy files.  For example, to allow avahi-daemon to use the system bus,
address@hidden must be equal to @code{(list avahi)}."
+  (service (type dbus-root-service-type)
+           (parameters (dbus-configuration (dbus dbus)
+                                           (services services)))))
+
+;;; dbus.scm ends here
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index 346f916..4176df6 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -20,7 +20,9 @@
 
 (define-module (gnu services desktop)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
   #:use-module (gnu services base)
+  #:use-module (gnu services dbus)
   #:use-module (gnu services avahi)
   #:use-module (gnu services xorg)
   #:use-module (gnu services networking)
@@ -31,16 +33,14 @@
   #:use-module (gnu packages freedesktop)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages avahi)
-  #:use-module (gnu packages wicd)
   #:use-module (gnu packages polkit)
-  #:use-module ((gnu packages linux)
-                #:select (lvm2 fuse alsa-utils crda))
   #:use-module (guix records)
+  #:use-module (guix packages)
   #:use-module (guix store)
   #:use-module (guix gexp)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
-  #:export (dbus-service
-            upower-service
+  #:export (upower-service
             colord-service
             geoclue-application
             %standard-geoclue-applications
@@ -64,133 +64,123 @@
 (define (bool value)
   (if value "true\n" "false\n"))
 
-
-;;;
-;;; D-Bus.
-;;;
 
-(define (dbus-configuration-directory dbus services)
-  "Return a configuration directory for @var{dbus} that includes the
address@hidden/dbus-1/system.d} directories of each package listed in
address@hidden"
-  (define build
-    #~(begin
-        (use-modules (sxml simple)
-                     (srfi srfi-1))
-
-        (define (services->sxml services)
-          ;; Return the SXML 'includedir' clauses for DIRS.
-          `(busconfig
-            ,@(append-map (lambda (dir)
-                            `((includedir
-                               ,(string-append dir "/etc/dbus-1/system.d"))
-                              (servicedir         ;for '.service' files
-                               ,(string-append dir "/share/dbus-1/services"))))
-                          services)))
-
-        (mkdir #$output)
-        (copy-file (string-append #$dbus "/etc/dbus-1/system.conf")
-                   (string-append #$output "/system.conf"))
-
-        ;; The default 'system.conf' has an <includedir> clause for
-        ;; 'system.d', so create it.
-        (mkdir (string-append #$output "/system.d"))
-
-        ;; 'system-local.conf' is automatically included by the default
-        ;; 'system.conf', so this is where we stuff our own things.
-        (call-with-output-file (string-append #$output "/system-local.conf")
-          (lambda (port)
-            (sxml->xml (services->sxml (list address@hidden))
-                       port)))))
-
-  (computed-file "dbus-configuration" build))
-
-(define* (dbus-service services #:key (dbus dbus))
-  "Return a service that runs the \"system bus\", using @var{dbus}, with
-support for @var{services}.
-
address@hidden://dbus.freedesktop.org/, D-Bus} is an inter-process communication
-facility.  Its system bus is used to allow system services to communicate and
-be notified of system-wide events.
-
address@hidden must be a list of packages that provide an
address@hidden/dbus-1/system.d} directory containing additional D-Bus 
configuration
-and policy files.  For example, to allow avahi-daemon to use the system bus,
address@hidden must be equal to @code{(list avahi)}."
-  (let ((conf (dbus-configuration-directory dbus services)))
-    (service
-     (documentation "Run the D-Bus system daemon.")
-     (provision '(dbus-system))
-     (requirement '(user-processes))
-     (start #~(make-forkexec-constructor
-               (list (string-append #$dbus "/bin/dbus-daemon")
-                     "--nofork"
-                     (string-append "--config-file=" #$conf "/system.conf"))))
-     (stop #~(make-kill-destructor))
-     (user-groups (list (user-group
-                         (name "messagebus")
-                         (system? #t))))
-     (user-accounts (list (user-account
-                           (name "messagebus")
-                           (group "messagebus")
-                           (system? #t)
-                           (comment "D-Bus system bus user")
-                           (home-directory "/var/run/dbus")
-                           (shell
-                            #~(string-append #$shadow "/sbin/nologin")))))
-     (activate #~(begin
-                   (use-modules (guix build utils))
-
-                   (mkdir-p "/var/run/dbus")
-
-                   (let ((user (getpwnam "messagebus")))
-                     (chown "/var/run/dbus"
-                            (passwd:uid user) (passwd:gid user)))
-
-                   (unless (file-exists? "/etc/machine-id")
-                     (format #t "creating /etc/machine-id...~%")
-                     (let ((prog (string-append #$dbus "/bin/dbus-uuidgen")))
-                       ;; XXX: We can't use 'system' because the initrd's
-                       ;; guile system(3) only works when 'sh' is in $PATH.
-                       (let ((pid (primitive-fork)))
-                         (if (zero? pid)
-                             (call-with-output-file "/etc/machine-id"
-                               (lambda (port)
-                                 (close-fdes 1)
-                                 (dup2 (port->fdes port) 1)
-                                 (execl prog)))
-                             (waitpid pid))))))))))
+(define (wrapped-dbus-service service program variable value)
+  "Return a wrapper for @var{service}, a package containing a D-Bus service,
+where @var{program} is wrapped such that environment variable @var{variable}
+is set to @var{value} when the bus daemon launches it."
+  (define wrapper
+    (program-file (string-append (package-name service) "-program-wrapper")
+                  #~(begin
+                      (setenv #$variable #$value)
+                      (apply execl (string-append #$service "/" #$program)
+                             (string-append #$service "/" #$program)
+                             (cdr (command-line))))))
+
+  (computed-file (string-append (package-name service) "-wrapper")
+                 #~(begin
+                     (use-modules (guix build utils))
+
+                     (define service-directory
+                       "/share/dbus-1/system-services")
+
+                     (mkdir-p (dirname (string-append #$output
+                                                      service-directory)))
+                     (copy-recursively (string-append #$service
+                                                      service-directory)
+                                       (string-append #$output
+                                                      service-directory))
+                     (symlink (string-append #$service "/etc") ;for etc/dbus-1
+                              (string-append #$output "/etc"))
+
+                     (for-each (lambda (file)
+                                 (substitute* file
+                                   
(("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
+                                     _ original-program arguments)
+                                    (string-append "Exec=" #$wrapper arguments
+                                                   "\n"))))
+                               (find-files #$output "\\.service$")))
+                 #:modules '((guix build utils))))
 
 
 ;;;
 ;;; Upower D-Bus service.
 ;;;
 
-(define* (upower-configuration-file #:key watts-up-pro? poll-batteries?
-                                    ignore-lid? use-percentage-for-policy?
-                                    percentage-low percentage-critical
-                                    percentage-action time-low
-                                    time-critical time-action
-                                    critical-power-action)
-  "Return an upower-daemon configuration file."
-  (plain-file "UPower.conf"
-              (string-append
-               "[UPower]\n"
-               "EnableWattsUpPro=" (bool watts-up-pro?)
-               "NoPollBatteries=" (bool (not poll-batteries?))
-               "IgnoreLid=" (bool ignore-lid?)
-               "UsePercentageForPolicy=" (bool use-percentage-for-policy?)
-               "PercentageLow=" (number->string percentage-low) "\n"
-               "PercentageCritical=" (number->string percentage-critical) "\n"
-               "PercentageAction=" (number->string percentage-action) "\n"
-               "TimeLow=" (number->string time-low) "\n"
-               "TimeCritical=" (number->string time-critical) "\n"
-               "TimeAction=" (number->string time-action) "\n"
-               "CriticalPowerAction=" (match critical-power-action
-                                        ('hybrid-sleep "HybridSleep")
-                                        ('hibernate "Hibernate")
-                                        ('power-off "PowerOff"))
-               "\n")))
+;; TODO: Export.
+(define-record-type† upower-configuration
+  (upower upower)
+  watts-up-pro? poll-batteries?
+  ignore-lid? use-percentage-for-policy?
+  percentage-low percentage-critical
+  percentage-action time-low
+  time-critical time-action
+  critical-power-action)
+
+(define* upower-configuration-file
+  ;; Return an upower-daemon configuration file.
+  (match-lambda
+    (($ <upower-configuration> upower
+        watts-up-pro? poll-batteries? ignore-lid? use-percentage-for-policy?
+        percentage-low percentage-critical percentage-action time-low
+        time-critical time-action critical-power-action)
+     (plain-file "UPower.conf"
+                 (string-append
+                  "[UPower]\n"
+                  "EnableWattsUpPro=" (bool watts-up-pro?)
+                  "NoPollBatteries=" (bool (not poll-batteries?))
+                  "IgnoreLid=" (bool ignore-lid?)
+                  "UsePercentageForPolicy=" (bool use-percentage-for-policy?)
+                  "PercentageLow=" (number->string percentage-low) "\n"
+                  "PercentageCritical=" (number->string percentage-critical) 
"\n"
+                  "PercentageAction=" (number->string percentage-action) "\n"
+                  "TimeLow=" (number->string time-low) "\n"
+                  "TimeCritical=" (number->string time-critical) "\n"
+                  "TimeAction=" (number->string time-action) "\n"
+                  "CriticalPowerAction=" (match critical-power-action
+                                           ('hybrid-sleep "HybridSleep")
+                                           ('hibernate "Hibernate")
+                                           ('power-off "PowerOff"))
+                  "\n")))))
+
+(define %upower-accounts                          ;XXX: useful?
+  (list (user-group (name "upower") (system? #t))
+        (user-account
+         (name "upower")
+         (group "upower")
+         (system? #t)
+         (comment "UPower daemon user")
+         (home-directory "/var/empty")
+         (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define %upower-activation
+  #~(begin
+      (use-modules (guix build utils))
+      (mkdir-p "/var/lib/upower")
+      (let ((user (getpwnam "upower")))
+        (chown "/var/lib/upower"
+               (passwd:uid user) (passwd:gid user)))))
+
+
+(define (upower-dbus-service config)
+  (list (wrapped-dbus-service (upower-configuration-upower config)
+                              "libexec/upowerd"
+                              "UPOWER_CONF_FILE_NAME"
+                              (upower-configuration-file config))))
+
+(define upower-service-type
+  (service-type (name 'upower)
+                (extensions
+                 (list (service-extension dbus-root-service-type
+                                          upower-dbus-service)
+                       (service-extension account-service-type
+                                          (const %upower-accounts))
+                       (service-extension activation-service-type
+                                          (const %upower-activation))
+                       (service-extension udev-service-type
+                                          (compose
+                                           list
+                                           upower-configuration-upower))))))
 
 (define* (upower-service #:key (upower upower)
                          (watts-up-pro? #f)
@@ -208,90 +198,78 @@ and policy files.  For example, to allow avahi-daemon to 
use the system bus,
 @command{upowerd}}, a system-wide monitor for power consumption and battery
 levels, with the given configuration settings.  It implements the
 @code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME."
-  (let ((config (upower-configuration-file
-                 #:watts-up-pro? watts-up-pro?
-                 #:poll-batteries? poll-batteries?
-                 #:ignore-lid? ignore-lid?
-                 #:use-percentage-for-policy? use-percentage-for-policy?
-                 #:percentage-low percentage-low
-                 #:percentage-critical percentage-critical
-                 #:percentage-action percentage-action
-                 #:time-low time-low
-                 #:time-critical time-critical
-                 #:time-action time-action
-                 #:critical-power-action critical-power-action)))
-    (service
-     (documentation "Run the UPower power and battery monitor.")
-     (provision '(upower-daemon))
-     (requirement '(dbus-system udev))
-
-     (start #~(make-forkexec-constructor
-               (list (string-append #$upower "/libexec/upowerd"))
-               #:environment-variables
-               (list (string-append "UPOWER_CONF_FILE_NAME=" #$config))))
-     (stop #~(make-kill-destructor))
-     (activate #~(begin
-                   (use-modules (guix build utils))
-                   (mkdir-p "/var/lib/upower")
-                   (let ((user (getpwnam "upower")))
-                     (chown "/var/lib/upower"
-                            (passwd:uid user) (passwd:gid user)))))
-
-     (user-groups (list (user-group
-                         (name "upower")
-                         (system? #t))))
-     (user-accounts (list (user-account
-                           (name "upower")
-                           (group "upower")
-                           (system? #t)
-                           (comment "UPower daemon user")
-                           (home-directory "/var/empty")
-                           (shell
-                            #~(string-append #$shadow "/sbin/nologin"))))))))
+  (let ((config (upower-configuration
+                 (watts-up-pro? watts-up-pro?)
+                 (poll-batteries? poll-batteries?)
+                 (ignore-lid? ignore-lid?)
+                 (use-percentage-for-policy? use-percentage-for-policy?)
+                 (percentage-low percentage-low)
+                 (percentage-critical percentage-critical)
+                 (percentage-action percentage-action)
+                 (time-low time-low)
+                 (time-critical time-critical)
+                 (time-action time-action)
+                 (critical-power-action critical-power-action))))
+    (service (type upower-service-type)
+             (parameters config))))
 
 
 ;;;
 ;;; Colord D-Bus service.
 ;;;
 
+(define %colord-activation
+  #~(begin
+      (use-modules (guix build utils))
+      (mkdir-p "/var/lib/colord")
+      (let ((user (getpwnam "colord")))
+        (chown "/var/lib/colord"
+               (passwd:uid user) (passwd:gid user)))))
+
+(define %colord-accounts
+  (list (user-group (name "colord") (system? #t))
+        (user-account
+         (name "colord")
+         (group "colord")
+         (system? #t)
+         (comment "colord daemon user")
+         (home-directory "/var/empty")
+         (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define colord-service-type
+  (service-type (name 'colord)
+                (extensions
+                 (list (service-extension account-service-type
+                                          (const %colord-accounts))
+                       (service-extension activation-service-type
+                                          (const %colord-activation))
+
+                       ;; Colord is a D-Bus service that dbus-daemon can
+                       ;; activate.
+                       (service-extension dbus-root-service-type list)
+
+                       ;; Colord provides "color device" rules for udev.
+                       (service-extension udev-service-type list)))))
+
 (define* (colord-service #:key (colord colord))
   "Return a service that runs @command{colord}, a system service with a D-Bus
 interface to manage the color profiles of input and output devices such as
 screens and scanners.  It is notably used by the GNOME Color Manager graphical
 tool.  See @uref{http://www.freedesktop.org/software/colord/, the colord web
 site} for more information."
-  (service
-   (documentation "Run the colord color management service.")
-   (provision '(colord-daemon))
-   (requirement '(dbus-system udev))
-
-   (start #~(make-forkexec-constructor
-             (list (string-append #$colord "/libexec/colord"))))
-   (stop #~(make-kill-destructor))
-   (activate #~(begin
-                 (use-modules (guix build utils))
-                 (mkdir-p "/var/lib/colord")
-                 (let ((user (getpwnam "colord")))
-                   (chown "/var/lib/colord"
-                          (passwd:uid user) (passwd:gid user)))))
-
-   (user-groups (list (user-group
-                       (name "colord")
-                       (system? #t))))
-   (user-accounts (list (user-account
-                         (name "colord")
-                         (group "colord")
-                         (system? #t)
-                         (comment "colord daemon user")
-                         (home-directory "/var/empty")
-                         (shell
-                          #~(string-append #$shadow "/sbin/nologin")))))))
+  (service (type colord-service-type)
+           (parameters colord)))
 
 
 ;;;
 ;;; GeoClue D-Bus service.
 ;;;
 
+(define-record-type† geoclue-configuration
+  (geoclue geoclue)
+  whitelist wifi-geolocation-url submit-data?
+  wifi-submission-url submission-nick applications)
+
 (define* (geoclue-application name #:key (allowed? #t) system? (users '()))
   "Configure default GeoClue access permissions for an application.  NAME is
 the Desktop ID of the application, without the .desktop part.  If ALLOWED? is
@@ -311,21 +289,48 @@ users are allowed."
         (geoclue-application "epiphany" #:system? #f)
         (geoclue-application "firefox" #:system? #f)))
 
-(define* (geoclue-configuration-file #:key whitelist wifi-geolocation-url
-                                     submit-data?
-                                     wifi-submission-url submission-nick
-                                     applications)
+(define* (geoclue-configuration-file config)
   "Return a geoclue configuration file."
   (plain-file "geoclue.conf"
               (string-append
                "[agent]\n"
-               "whitelist=" (string-join whitelist ";") "\n"
+               "whitelist="
+               (string-join (geoclue-configuration-whitelist config)
+                            ";") "\n"
                "[wifi]\n"
-               "url=" wifi-geolocation-url "\n"
-               "submit-data=" (bool submit-data?)
-               "submission-url=" wifi-submission-url "\n"
-               "submission-nick=" submission-nick "\n"
-               (string-join applications "\n"))))
+               "url=" (geoclue-configuration-wifi-geolocation-url config) "\n"
+               "submit-data=" (bool (geoclue-configuration-submit-data? 
config))
+               "submission-url="
+               (geoclue-configuration-wifi-submission-url config) "\n"
+               "submission-nick="
+               (geoclue-configuration-submission-nick config)
+               "\n"
+               (string-join (geoclue-configuration-applications config)
+                            "\n"))))
+
+(define (geoclue-dbus-service config)
+  (list (wrapped-dbus-service (geoclue-configuration-geoclue config)
+                              "libexec/geoclue"
+                              "GEOCLUE_CONFIG_FILE"
+                              (geoclue-configuration-file config))))
+
+(define %geoclue-accounts
+  (list (user-group (name "geoclue") (system? #t))
+        (user-account
+         (name "geoclue")
+         (group "geoclue")
+         (system? #t)
+         (comment "GeoClue daemon user")
+         (home-directory "/var/empty")
+         (shell "/run/current-system/profile/sbin/nologin"))))
+
+(define geoclue-service-type
+  (service-type (name 'geoclue)
+                (extensions
+                 (list (service-extension dbus-root-service-type
+                                          geoclue-dbus-service)
+                       (service-extension account-service-type
+                                          (const %geoclue-accounts))))))
 
 (define* (geoclue-service #:key (geoclue geoclue)
                           (whitelist '())
@@ -345,70 +350,54 @@ and Epiphany web browsers are able to ask for the user's 
location, and in the
 case of Icecat and Epiphany, both will ask the user for permission first.  See
 @uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web
 site} for more information."
-  (let ((config (geoclue-configuration-file
-                 #:whitelist whitelist
-                 #:wifi-geolocation-url wifi-geolocation-url
-                 #:submit-data? submit-data?
-                 #:wifi-submission-url wifi-submission-url
-                 #:submission-nick submission-nick
-                 #:applications applications)))
-    (service
-     (documentation "Run the GeoClue location service.")
-     (provision '(geoclue-daemon))
-     (requirement '(dbus-system))
-
-     (start #~(make-forkexec-constructor
-               (list (string-append #$geoclue "/libexec/geoclue"))
-               #:user "geoclue"
-               #:environment-variables
-               (list (string-append "GEOCLUE_CONFIG_FILE=" #$config))))
-     (stop #~(make-kill-destructor))
-
-     (user-groups (list (user-group
-                         (name "geoclue")
-                         (system? #t))))
-     (user-accounts (list (user-account
-                           (name "geoclue")
-                           (group "geoclue")
-                           (system? #t)
-                           (comment "GeoClue daemon user")
-                           (home-directory "/var/empty")
-                           (shell
-                            "/run/current-system/profile/sbin/nologin")))))))
+  (service (type geoclue-service-type)
+           (parameters (geoclue-configuration
+                        (geoclue geoclue)
+                        (whitelist whitelist)
+                        (wifi-geolocation-url wifi-geolocation-url)
+                        (submit-data? submit-data?)
+                        (wifi-submission-url wifi-submission-url)
+                        (submission-nick submission-nick)
+                        (applications applications)))))
 
 
 ;;;
 ;;; Polkit privilege management service.
 ;;;
 
+(define %polkit-accounts
+  (list (user-group (name "polkitd") (system? #t))
+        (user-account
+         (name "polkitd")
+         (group "polkitd")
+         (system? #t)
+         (comment "Polkit daemon user")
+         (home-directory "/var/empty")
+         (shell "/run/current-system/profile/sbin/nologin"))))
+
+(define %polkit-pam-services
+  (list (unix-pam-service "polkit-1")))
+
+(define polkit-service-type
+  ;; TODO: Make it extensible so it can collect policy files from other
+  ;; services.
+  (service-type (name 'polkit)
+                (extensions
+                 (list (service-extension account-service-type
+                                          (const %polkit-accounts))
+                       (service-extension pam-root-service-type
+                                          (const %polkit-pam-services))
+                       (service-extension dbus-root-service-type
+                                          list)))))
+
 (define* (polkit-service #:key (polkit polkit))
   "Return a service that runs the @command{polkit} privilege management
 service.  By querying the @command{polkit} service, a privileged system
 component can know when it should grant additional capabilities to ordinary
 users.  For example, an ordinary user can be granted the capability to suspend
 the system if the user is logged in locally."
-  (service
-   (documentation "Run the polkit privilege management service.")
-   (provision '(polkit-daemon))
-   (requirement '(dbus-system))
-
-   (start #~(make-forkexec-constructor
-             (list (string-append #$polkit "/lib/polkit-1/polkitd"))))
-   (stop #~(make-kill-destructor))
-
-   (user-groups (list (user-group
-                       (name "polkitd")
-                       (system? #t))))
-   (user-accounts (list (user-account
-                         (name "polkitd")
-                         (group "polkitd")
-                         (system? #t)
-                         (comment "Polkit daemon user")
-                         (home-directory "/var/empty")
-                         (shell
-                          "/run/current-system/profile/sbin/nologin"))))
-
-   (pam-services (list (unix-pam-service "polkit-1")))))
+  (service (type polkit-service-type)
+           (parameters polkit)))
 
 
 ;;;
@@ -418,6 +407,8 @@ the system if the user is logged in locally."
 (define-record-type* <elogind-configuration> elogind-configuration
   make-elogind-configuration
   elogind-configuration
+  (elogind                         elogind-package
+                                   (default elogind))
   (kill-user-processes?            elogind-kill-user-processes?
                                    (default #f))
   (kill-only-users                 elogind-kill-only-users
@@ -547,67 +538,63 @@ the system if the user is logged in locally."
    ("HybridSleepState" (sleep-list elogind-hybrid-sleep-state))
    ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode))))
 
-(define* (elogind-service #:key (elogind elogind)
-                          (config (elogind-configuration)))
+(define (elogind-dmd-service config)
+  "Return a dmd service for elogind, using @var{config}."
+  (let ((config-file (elogind-configuration-file config))
+        (elogind     (elogind-package config)))
+    (list (dmd-service
+           (documentation "Run the elogind login and seat management service.")
+           (provision '(elogind))
+           (requirement '(dbus-system))
+
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$elogind 
"/libexec/elogind/elogind"))
+                     #:environment-variables
+                     (list (string-append "ELOGIND_CONF_FILE=" 
#$config-file))))
+           (stop #~(make-kill-destructor))))))
+
+(define elogind-service-type
+  (service-type (name 'elogind)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          elogind-dmd-service)
+                       (service-extension dbus-root-service-type
+                                          (compose list elogind-package))
+                       (service-extension udev-service-type
+                                          (compose list elogind-package))
+                       ;; TODO: Extend polkit(?) and PAM.
+                       ))))
+
+(define* (elogind-service #:key (config (elogind-configuration)))
   "Return a service that runs the @command{elogind} login and seat management
 service.  The @command{elogind} service integrates with PAM to allow other
 system components to know the set of logged-in users as well as their session
 types (graphical, console, remote, etc.).  It can also clean up after users
 when they log out."
-  (let ((config-file (elogind-configuration-file config)))
-    (service
-     (documentation "Run the elogind login and seat management service.")
-     (provision '(elogind))
-     (requirement '(dbus-system))
-
-     (start #~(make-forkexec-constructor
-               (list (string-append #$elogind "/libexec/elogind/elogind"))
-               #:environment-variables
-               (list (string-append "ELOGIND_CONF_FILE=" #$config-file))))
-     (stop #~(make-kill-destructor)))))
+  (service (type elogind-service-type)
+           (parameters config)))
 
 
 ;;;
 ;;; The default set of desktop services.
 ;;;
+
 (define %desktop-services
   ;; List of services typically useful for a "desktop" use case.
   (cons* (slim-service)
 
+         ;; The D-Bus clique.
          (avahi-service)
          (wicd-service)
          (upower-service)
-         ;; FIXME: The colord, geoclue, and polkit services could all be
-         ;; bus-activated by default, so they don't run at program startup.
-         ;; However, user creation and /var/lib/colord creation happen at
-         ;; service activation time, so we currently add them to the set of
-         ;; default services.
          (colord-service)
          (geoclue-service)
          (polkit-service)
          (elogind-service)
-         (dbus-service (list avahi wicd upower colord geoclue polkit elogind))
+         (dbus-service)
 
          (ntp-service)
 
-         (map (lambda (service)
-                (cond
-                 ;; Provide an nscd ready to use nss-mdns.
-                 ((memq 'nscd (service-provision service))
-                  (nscd-service (nscd-configuration
-                                 (name-services (list nss-mdns)))))
-
-                 ;; Add more rules to udev-service.
-                 ;;
-                 ;; XXX Keep this in sync with the 'udev-service' call in
-                 ;; %base-services.  Here we intend only to add 'upower',
-                 ;; 'colord', and 'elogind'.
-                 ((memq 'udev (service-provision service))
-                  (udev-service #:rules
-                                (list lvm2 fuse alsa-utils crda
-                                      upower colord elogind)))
-
-                 (else service)))
-              %base-services)))
+         %base-services))
 
 ;;; desktop.scm ends here
diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index 618df91..1cf5395 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -22,13 +22,20 @@
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
+  #:use-module (guix records)
   #:use-module (guix derivations)                 ;imported-modules, etc.
   #:use-module (gnu services)
+  #:use-module (gnu packages admin)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
-  #:export (dmd-configuration-file))
+  #:export (dmd-root-service-type
+            %dmd-root-service
+            dmd-service-type
+
+            dmd-service
+            dmd-service?))
 
 ;;; Commentary:
 ;;;
@@ -36,6 +43,70 @@
 ;;;
 ;;; Code:
 
+
+(define (dmd-boot-gexp services)
+  (mlet %store-monad ((dmd-conf (dmd-configuration-file services)))
+    (return #~(begin
+                ;; Keep track of the booted system.
+                (false-if-exception (delete-file "/run/booted-system"))
+                (symlink (readlink "/run/current-system")
+                         "/run/booted-system")
+
+                ;; Close any remaining open file descriptors to be on the safe
+                ;; side.  This must be the very last thing we do, because
+                ;; Guile has internal FDs such as 'sleep_pipe' that need to be
+                ;; alive.
+                (let loop ((fd 3))
+                  (when (< fd 1024)
+                    (false-if-exception (close-fdes fd))
+                    (loop (+ 1 fd))))
+
+                ;; Start dmd.
+                (execl (string-append #$dmd "/bin/dmd")
+                       "dmd" "--config" #$dmd-conf)))))
+
+(define dmd-root-service-type
+  (service-type
+   (name 'dmd-root)
+   ;; Extending the root dmd service (aka. PID 1) happens by concatenating the
+   ;; list of services provided by the extensions.
+   (compose concatenate)
+   (extend append)
+   (extensions (list (service-extension boot-service-type
+                                        dmd-boot-gexp)))))
+
+(define %dmd-root-service
+  ;; The root dmd service, aka. PID 1.
+  (service
+   (type dmd-root-service-type)
+   (parameters '())))                             ;list of <dmd-service>
+
+(define-syntax-rule (dmd-service-type proc)
+  "Return a <service-type> denoting a simple dmd service--i.e., the type for a
+service that extends DMD-ROOT-SERVICE-TYPE and nothing else."
+  (service-type
+   (name 'some-dmd-service)
+   (extensions
+    (list (service-extension dmd-root-service-type
+                             (compose list proc))))))
+
+(define-record-type* <dmd-service>
+  dmd-service make-dmd-service
+  dmd-service?
+  (documentation service-documentation            ; string
+                 (default "[No documentation.]"))
+  (provision     service-provision)               ; list of symbols
+  (requirement   service-requirement              ; list of symbols
+                 (default '()))
+  (respawn?      service-respawn?                 ; Boolean
+                 (default #t))
+  (start         service-start)                   ; g-expression (procedure)
+  (stop          service-stop                     ; g-expression (procedure)
+                 (default #~(const #f)))
+  (auto-start?   service-auto-start?              ; Boolean
+                 (default #t)))
+
+
 (define (assert-no-duplicates services)
   "Raise an error if SERVICES provide the same dmd service more than once.
 
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 50ffac5..c12687d 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -19,7 +19,10 @@
 
 (define-module (gnu services networking)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
+  #:use-module (gnu services dbus)
   #:use-module (gnu system shadow)
+  #:use-module (gnu system linux)                 ;PAM
   #:use-module (gnu packages admin)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages tor)
@@ -27,8 +30,9 @@
   #:use-module (gnu packages ntp)
   #:use-module (gnu packages wicd)
   #:use-module (guix gexp)
-  #:use-module (guix store)
+  #:use-module (guix records)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
   #:export (%facebook-host-aliases
             static-networking-service
             dhcp-client-service
@@ -78,6 +82,65 @@ fe80::1%lo0 www.connect.facebook.net
 fe80::1%lo0 apps.facebook.com\n")
 
 
+(define-record-type† static-networking
+  interface ip gateway provision name-servers net-tools)
+
+(define static-networking-service-type
+  (dmd-service-type
+   (match-lambda
+     (($ <static-networking> interface ip gateway provision
+                             name-servers net-tools)
+      (let ((loopback? (memq 'loopback provision)))
+
+        ;; TODO: Eventually replace 'route' with bindings for the appropriate
+        ;; ioctls.
+        (dmd-service
+
+         ;; Unless we're providing the loopback interface, wait for udev to be 
up
+         ;; and running so that INTERFACE is actually usable.
+         (requirement (if loopback? '() '(udev)))
+
+         (documentation
+          "Bring up the networking interface using a static IP address.")
+         (provision provision)
+         (start #~(lambda _
+                    ;; Return #t if successfully started.
+                    (let* ((addr     (inet-pton AF_INET #$ip))
+                           (sockaddr (make-socket-address AF_INET addr 0)))
+                      (configure-network-interface #$interface sockaddr
+                                                   (logior IFF_UP
+                                                           #$(if loopback?
+                                                                 #~IFF_LOOPBACK
+                                                                 0))))
+                    #$(if gateway
+                          #~(zero? (system* (string-append #$net-tools
+                                                           "/sbin/route")
+                                            "add" "-net" "default"
+                                            "gw" #$gateway))
+                          #t)
+                    #$(if (pair? name-servers)
+                          #~(call-with-output-file "/etc/resolv.conf"
+                              (lambda (port)
+                                (display
+                                 "# Generated by 
'static-networking-service'.\n"
+                                 port)
+                                (for-each (lambda (server)
+                                            (format port "nameserver ~a~%"
+                                                    server))
+                                          '#$name-servers)))
+                          #t)))
+         (stop #~(lambda _
+                   ;; Return #f is successfully stopped.
+                   (let ((sock (socket AF_INET SOCK_STREAM 0)))
+                     (set-network-interface-flags sock #$interface 0)
+                     (close-port sock))
+                   (not #$(if gateway
+                              #~(system* (string-append #$net-tools
+                                                        "/sbin/route")
+                                         "del" "-net" "default")
+                              #t))))
+         (respawn? #f)))))))
+
 (define* (static-networking-service interface ip
                                     #:key
                                     gateway
@@ -87,111 +150,71 @@ fe80::1%lo0 apps.facebook.com\n")
   "Return a service that starts @var{interface} with address @var{ip}.  If
 @var{gateway} is true, it must be a string specifying the default network
 gateway."
-  (define loopback?
-    (memq 'loopback provision))
-
-  ;; TODO: Eventually replace 'route' with bindings for the appropriate
-  ;; ioctls.
-  (service
-
-   ;; Unless we're providing the loopback interface, wait for udev to be up
-   ;; and running so that INTERFACE is actually usable.
-   (requirement (if loopback? '() '(udev)))
-
-   (documentation
-    "Bring up the networking interface using a static IP address.")
-   (provision provision)
-   (start #~(lambda _
-              ;; Return #t if successfully started.
-              (let* ((addr     (inet-pton AF_INET #$ip))
-                     (sockaddr (make-socket-address AF_INET addr 0)))
-                (configure-network-interface #$interface sockaddr
-                                             (logior IFF_UP
-                                                     #$(if loopback?
-                                                           #~IFF_LOOPBACK
-                                                           0))))
-              #$(if gateway
-                    #~(zero? (system* (string-append #$net-tools
-                                                     "/sbin/route")
-                                      "add" "-net" "default"
-                                      "gw" #$gateway))
-                    #t)
-              #$(if (pair? name-servers)
-                    #~(call-with-output-file "/etc/resolv.conf"
-                        (lambda (port)
-                          (display
-                           "# Generated by 'static-networking-service'.\n"
-                           port)
-                          (for-each (lambda (server)
-                                      (format port "nameserver ~a~%"
-                                              server))
-                                    '#$name-servers)))
-                    #t)))
-   (stop #~(lambda _
-             ;; Return #f is successfully stopped.
-             (let ((sock (socket AF_INET SOCK_STREAM 0)))
-               (set-network-interface-flags sock #$interface 0)
-               (close-port sock))
-             (not #$(if gateway
-                        #~(system* (string-append #$net-tools
-                                                  "/sbin/route")
-                                   "del" "-net" "default")
-                        #t))))
-   (respawn? #f)))
+  (service (type static-networking-service-type)
+           (parameters (static-networking (interface interface) (ip ip)
+                                          (gateway gateway)
+                                          (provision provision)
+                                          (name-servers name-servers)
+                                          (net-tools net-tools)))))
+
+(define dhcp-client-service-type
+  (dmd-service-type
+   (lambda (dhcp)
+     (define dhclient
+       #~(string-append #$dhcp "/sbin/dhclient"))
+
+     (define pid-file
+       "/var/run/dhclient.pid")
+
+     (dmd-service
+      (documentation "Set up networking via DHCP.")
+      (requirement '(user-processes udev))
+
+      ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
+      ;; networking is unavailable, but also means that the interface is not up
+      ;; yet when 'start' completes.  To wait for the interface to be ready, 
one
+      ;; should instead monitor udev events.
+      (provision '(networking))
+
+      (start #~(lambda _
+                 ;; When invoked without any arguments, 'dhclient' discovers 
all
+                 ;; non-loopback interfaces *that are up*.  However, the 
relevant
+                 ;; interfaces are typically down at this point.  Thus we 
perform
+                 ;; our own interface discovery here.
+                 (define valid?
+                   (negate loopback-network-interface?))
+                 (define ifaces
+                   (filter valid? (all-network-interface-names)))
+
+                 ;; XXX: Make sure the interfaces are up so that 'dhclient' can
+                 ;; actually send/receive over them.
+                 (for-each set-network-interface-up ifaces)
+
+                 (false-if-exception (delete-file #$pid-file))
+                 (let ((pid (fork+exec-command
+                             (cons* #$dhclient "-nw"
+                                    "-pf" #$pid-file ifaces))))
+                   (and (zero? (cdr (waitpid pid)))
+                        (let loop ()
+                          (catch 'system-error
+                            (lambda ()
+                              (call-with-input-file #$pid-file read))
+                            (lambda args
+                              ;; 'dhclient' returned before PID-FILE was 
created,
+                              ;; so try again.
+                              (let ((errno (system-error-errno args)))
+                                (if (= ENOENT errno)
+                                    (begin
+                                      (sleep 1)
+                                      (loop))
+                                    (apply throw args))))))))))
+      (stop #~(make-kill-destructor))))))
 
 (define* (dhcp-client-service #:key (dhcp isc-dhcp))
   "Return a service that runs @var{dhcp}, a Dynamic Host Configuration
 Protocol (DHCP) client, on all the non-loopback network interfaces."
-
-  (define dhclient
-    #~(string-append #$dhcp "/sbin/dhclient"))
-
-  (define pid-file
-    "/var/run/dhclient.pid")
-
-  (service
-   (documentation "Set up networking via DHCP.")
-   (requirement '(user-processes udev))
-
-   ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
-   ;; networking is unavailable, but also means that the interface is not up
-   ;; yet when 'start' completes.  To wait for the interface to be ready, one
-   ;; should instead monitor udev events.
-   (provision '(networking))
-
-   (start #~(lambda _
-              ;; When invoked without any arguments, 'dhclient' discovers all
-              ;; non-loopback interfaces *that are up*.  However, the relevant
-              ;; interfaces are typically down at this point.  Thus we perform
-              ;; our own interface discovery here.
-              (define valid?
-                (negate loopback-network-interface?))
-              (define ifaces
-                (filter valid? (all-network-interface-names)))
-
-              ;; XXX: Make sure the interfaces are up so that 'dhclient' can
-              ;; actually send/receive over them.
-              (for-each set-network-interface-up ifaces)
-
-              (false-if-exception (delete-file #$pid-file))
-              (let ((pid (fork+exec-command
-                          (cons* #$dhclient "-nw"
-                                 "-pf" #$pid-file ifaces))))
-                (and (zero? (cdr (waitpid pid)))
-                     (let loop ()
-                       (catch 'system-error
-                         (lambda ()
-                           (call-with-input-file #$pid-file read))
-                         (lambda args
-                           ;; 'dhclient' returned before PID-FILE was created,
-                           ;; so try again.
-                           (let ((errno (system-error-errno args)))
-                             (if (= ENOENT errno)
-                                 (begin
-                                   (sleep 1)
-                                   (loop))
-                                 (apply throw args))))))))))
-   (stop #~(make-kill-destructor))))
+  (service (type dhcp-client-service-type)
+           (parameters dhcp)))
 
 (define %ntp-servers
   ;; Default set of NTP servers.
@@ -199,19 +222,25 @@ Protocol (DHCP) client, on all the non-loopback network 
interfaces."
     "1.pool.ntp.org"
     "2.pool.ntp.org"))
 
-(define* (ntp-service #:key (ntp ntp)
-                      (servers %ntp-servers))
-  "Return a service that runs the daemon from @var{ntp}, the
address@hidden://www.ntp.org, Network Time Protocol package}.  The daemon will
-keep the system clock synchronized with that of @var{servers}."
-  ;; TODO: Add authentication support.
-
-  (define config
-    (string-append "driftfile /var/run/ntp.drift\n"
-                   (string-join (map (cut string-append "server " <>)
-                                     servers)
-                                "\n")
-                   "
+
+;;;
+;;; NTP.
+;;;
+
+(define-record-type† ntp-configuration
+  ntp servers)
+
+(define ntp-dmd-service
+  (match-lambda
+    (($ <ntp-configuration> ntp servers)
+     (let ()
+       ;; TODO: Add authentication support.
+       (define config
+         (string-append "driftfile /var/run/ntp.drift\n"
+                        (string-join (map (cut string-append "server " <>)
+                                          servers)
+                                     "\n")
+                        "
 # Disable status queries as a workaround for CVE-2013-5211:
 # 
<http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>.
 restrict default kod nomodify notrap nopeer noquery
@@ -221,55 +250,149 @@ restrict -6 default kod nomodify notrap nopeer noquery
 restrict 127.0.0.1
 restrict -6 ::1\n"))
 
-  (let ((ntpd.conf (plain-file "ntpd.conf" config)))
-    (service
-     (provision '(ntpd))
-     (documentation "Run the Network Time Protocol (NTP) daemon.")
-     (requirement '(user-processes networking))
-     (start #~(make-forkexec-constructor
-               (list (string-append #$ntp "/bin/ntpd") "-n"
-                     "-c" #$ntpd.conf
-                     "-u" "ntpd")))
-     (stop #~(make-kill-destructor))
-     (user-accounts (list (user-account
-                           (name "ntpd")
-                           (group "nogroup")
-                           (system? #t)
-                           (comment "NTP daemon user")
-                           (home-directory "/var/empty")
-                           (shell
-                            #~(string-append #$shadow "/sbin/nologin"))))))))
+       (define ntpd.conf
+         (plain-file "ntpd.conf" config))
+
+       (list (dmd-service
+              (provision '(ntpd))
+              (documentation "Run the Network Time Protocol (NTP) daemon.")
+              (requirement '(user-processes networking))
+              (start #~(make-forkexec-constructor
+                        (list (string-append #$ntp "/bin/ntpd") "-n"
+                              "-c" #$ntpd.conf "-u" "ntpd")))
+              (stop #~(make-kill-destructor))))))))
+
+(define %ntp-accounts
+  (list (user-account
+         (name "ntpd")
+         (group "nogroup")
+         (system? #t)
+         (comment "NTP daemon user")
+         (home-directory "/var/empty")
+         (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define ntp-service-type
+  (service-type (name 'ntp)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          ntp-dmd-service)
+                       (service-extension account-service-type
+                                          (const %ntp-accounts))))))
+
+(define* (ntp-service #:key (ntp ntp)
+                      (servers %ntp-servers))
+  "Return a service that runs the daemon from @var{ntp}, the
address@hidden://www.ntp.org, Network Time Protocol package}.  The daemon will
+keep the system clock synchronized with that of @var{servers}."
+  (service (type ntp-service-type)
+           (parameters (ntp-configuration (ntp ntp) (servers servers)))))
+
+(define (tor-dmd-service tor)
+  "Return a <dmd-service> running TOR."
+  (let ((torrc (plain-file "torrc" "User tor\n")))
+    (list (dmd-service
+           (provision '(tor))
+
+           ;; Tor needs at least one network interface to be up, hence the
+           ;; dependency on 'loopback'.
+           (requirement '(user-processes loopback))
+
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$tor "/bin/tor") "-f" #$torrc)))
+           (stop #~(make-kill-destructor))
+           (documentation "Run the Tor anonymous network overlay.")))))
+
+
+;;;
+;;; Tor.
+;;;
+
+(define %tor-accounts
+  ;; User account and groups for Tor.
+  (list (user-group (name "tor") (system? #t))
+        (user-account
+         (name "tor")
+         (group "tor")
+         (system? #t)
+         (comment "Tor daemon user")
+         (home-directory "/var/empty")
+         (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define tor-service-type
+  (service-type (name 'tor)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          tor-dmd-service)
+                       (service-extension account-service-type
+                                          (const %tor-accounts))))))
 
 (define* (tor-service #:key (tor tor))
   "Return a service to run the @uref{https://torproject.org,Tor} daemon.
 
 The daemon runs with the default settings (in particular the default exit
 policy) as the @code{tor} unprivileged user."
-  (let ((torrc (plain-file "torrc" "User tor\n")))
-    (service
-     (provision '(tor))
-
-     ;; Tor needs at least one network interface to be up, hence the
-     ;; dependency on 'loopback'.
-     (requirement '(user-processes loopback))
-
-     (start #~(make-forkexec-constructor
-               (list (string-append #$tor "/bin/tor") "-f" #$torrc)))
-     (stop #~(make-kill-destructor))
-
-     (user-groups   (list (user-group
-                           (name "tor")
-                           (system? #t))))
-     (user-accounts (list (user-account
-                           (name "tor")
-                           (group "tor")
-                           (system? #t)
-                           (comment "Tor daemon user")
-                           (home-directory "/var/empty")
-                           (shell
-                            #~(string-append #$shadow "/sbin/nologin")))))
-
-     (documentation "Run the Tor anonymous network overlay."))))
+  (service (type tor-service-type)
+           (parameters tor)))
+
+
+;;;
+;;; BitlBee.
+;;;
+
+(define-record-type† bitlbee-configuration
+  (bitlbee bitlbee) interface port extra-settings)
+
+(define bitlbee-dmd-service
+  (match-lambda
+    (($ <bitlbee-configuration> bitlbee interface port extra-settings)
+     (let ((conf (plain-file "bitlbee.conf"
+                             (string-append "
+  [settings]
+  User = bitlbee
+  ConfigDir = /var/lib/bitlbee
+  DaemonInterface = " interface "
+  DaemonPort = " (number->string port) "
+" extra-settings))))
+
+       (list (dmd-service
+              (provision '(bitlbee))
+              (requirement '(user-processes loopback))
+              (start #~(make-forkexec-constructor
+                        (list (string-append #$bitlbee "/sbin/bitlbee")
+                              "-n" "-F" "-u" "bitlbee" "-c" #$conf)))
+              (stop  #~(make-kill-destructor))))))))
+
+(define %bitlbee-accounts
+  ;; User group and account to run BitlBee.
+  (list (user-group (name "bitlbee") (system? #t))
+        (list (user-account
+               (name "bitlbee")
+               (group "bitlbee")
+               (system? #t)
+               (comment "BitlBee daemon user")
+               (home-directory "/var/empty")
+               (shell #~(string-append #$shadow "/sbin/nologin"))))))
+
+(define %bitlbee-activation
+  ;; Activation gexp for BitlBee.
+  #~(begin
+      (use-modules (guix build utils))
+
+      ;; This directory is used to store OTR data.
+      (mkdir-p "/var/lib/bitlbee")
+      (let ((user (getpwnam "bitlbee")))
+        (chown "/var/lib/bitlbee"
+               (passwd:uid user) (passwd:gid user)))))
+
+(define bitlbee-service-type
+  (service-type (name 'bitlbee)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          bitlbee-dmd-service)
+                       (service-extension account-service-type
+                                          (const %bitlbee-accounts))
+                       (service-extension activation-service-type
+                                          (const %bitlbee-activation))))))
 
 (define* (bitlbee-service #:key (bitlbee bitlbee)
                           (interface "127.0.0.1") (port 6667)
@@ -284,57 +407,53 @@ come from any networking interface.
 
 In addition, @var{extra-settings} specifies a string to append to the
 configuration file."
-  (let ((conf (plain-file "bitlbee.conf"
-                          (string-append "
-  [settings]
-  User = bitlbee
-  ConfigDir = /var/lib/bitlbee
-  DaemonInterface = " interface "
-  DaemonPort = " (number->string port) "
-" extra-settings))))
-    (service
-     (provision '(bitlbee))
-     (requirement '(user-processes loopback))
-     (activate #~(begin
-                   (use-modules (guix build utils))
-
-                   ;; This directory is used to store OTR data.
-                   (mkdir-p "/var/lib/bitlbee")
-                   (let ((user (getpwnam "bitlbee")))
-                     (chown "/var/lib/bitlbee"
-                            (passwd:uid user) (passwd:gid user)))))
-     (start #~(make-forkexec-constructor
-               (list (string-append #$bitlbee "/sbin/bitlbee")
-                     "-n" "-F" "-u" "bitlbee" "-c" #$conf)))
-     (stop  #~(make-kill-destructor))
-     (user-groups   (list (user-group (name "bitlbee") (system? #t))))
-     (user-accounts (list (user-account
-                           (name "bitlbee")
-                           (group "bitlbee")
-                           (system? #t)
-                           (comment "BitlBee daemon user")
-                           (home-directory "/var/empty")
-                           (shell #~(string-append #$shadow
-                                                   "/sbin/nologin"))))))))
+  (service (type bitlbee-service-type)
+           (parameters (bitlbee-configuration
+                        (bitlbee bitlbee)
+                        (interface interface) (port port)
+                        (extra-settings extra-settings)))))
+
+
+;;;
+;;; Wicd.
+;;;
+
+(define %wicd-activation
+  ;; Activation gexp for Wicd.
+  #~(begin
+      (use-modules (guix build utils))
+
+      (mkdir-p "/etc/wicd")
+      (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
+        (unless (file-exists? file-name)
+          (copy-file (string-append #$wicd file-name)
+                     file-name)))))
+
+(define (wicd-dmd-service wicd)
+  "Return a dmd service for WICD."
+  (list (dmd-service
+         (documentation "Run the Wicd network manager.")
+         (provision '(networking))
+         (requirement '(user-processes dbus-system loopback))
+         (start #~(make-forkexec-constructor
+                   (list (string-append #$wicd "/sbin/wicd")
+                         "--no-daemon")))
+         (stop #~(make-kill-destructor)))))
+
+(define wicd-service-type
+  (service-type (name 'wicd)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          wicd-dmd-service)
+                       (service-extension dbus-root-service-type
+                                          list)
+                       (service-extension activation-service-type
+                                          (const %wicd-activation))))))
 
 (define* (wicd-service #:key (wicd wicd))
   "Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network
 manager that aims to simplify wired and wireless networking."
-  (service
-   (documentation "Run the Wicd network manager.")
-   (provision '(networking))
-   (requirement '(user-processes dbus-system loopback))
-   (start #~(make-forkexec-constructor
-             (list (string-append #$wicd "/sbin/wicd")
-                   "--no-daemon")))
-   (stop #~(make-kill-destructor))
-   (activate
-    #~(begin
-        (use-modules (guix build utils))
-        (mkdir-p "/etc/wicd")
-        (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
-          (unless (file-exists? file-name)
-            (copy-file (string-append #$wicd file-name)
-                       file-name)))))))
+  (service (type wicd-service-type)
+           (parameters wicd)))
 
 ;;; networking.scm ends here
diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm
index 3fa0976..292aa43 100644
--- a/gnu/services/ssh.scm
+++ b/gnu/services/ssh.scm
@@ -18,8 +18,9 @@
 
 (define-module (gnu services ssh)
   #:use-module (guix gexp)
-  #:use-module (guix store)
+  #:use-module (guix records)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
   #:use-module (gnu system linux)                 ; 'pam-service'
   #:use-module (gnu packages lsh)
   #:export (lsh-service))
@@ -30,11 +31,18 @@
 ;;;
 ;;; Code:
 
+(define-record-type† lsh-configuration
+  ;; TODO: Export.
+  lsh daemonic? host-key interfaces port-number
+  allow-empty-passwords? root-login? syslog-output? pid-file? pid-file
+  x11-forwarding? tcp/ip-forwarding? password-authentication?
+  public-key-authentication? initialize?)
+
 (define %yarrow-seed
   "/var/spool/lsh/yarrow-seed-file")
 
-(define (activation lsh host-key)
-  "Return the gexp to activate the LSH service for HOST-KEY."
+(define (lsh-initialization lsh host-key)
+  "Return the gexp to initialize the LSH service for HOST-KEY."
   #~(begin
       (unless (file-exists? #$%yarrow-seed)
         (system* (string-append #$lsh "/bin/lsh-make-seed")
@@ -70,6 +78,88 @@
                   (waitpid keygen)
                   (waitpid write-key))))))))))
 
+(define (lsh-activation config)
+  "Return the activation gexp for CONFIG."
+  #~(begin
+      (use-modules (guix build utils))
+      (mkdir-p "/var/spool/lsh")
+      #$(if (lsh-configuration-initialize? config)
+            (lsh-initialization (lsh-configuration-lsh config)
+                                (lsh-configuration-host-key config))
+            #t)))
+
+(define (lsh-dmd-service config)
+  "Return a <dmd-service> for lsh with CONFIG."
+  (define lsh (lsh-configuration-lsh config))
+  (define pid-file (lsh-configuration-pid-file config))
+  (define pid-file? (lsh-configuration-pid-file? config))
+  (define daemonic? (lsh-configuration-daemonic? config))
+  (define interfaces (lsh-configuration-interfaces config))
+
+  (define lsh-command
+    (append
+     (cons #~(string-append #$lsh "/sbin/lshd")
+           (if daemonic?
+               (let ((syslog (if (lsh-configuration-syslog-output? config)
+                                 '()
+                                 (list "--no-syslog"))))
+                 (cons "--daemonic"
+                       (if pid-file?
+                           (cons #~(string-append "--pid-file=" #$pid-file)
+                                 syslog)
+                           (cons "--no-pid-file" syslog))))
+               (if pid-file?
+                   (list #~(string-append "--pid-file=" #$pid-file))
+                   '())))
+     (cons* #~(string-append "--host-key="
+                             #$(lsh-configuration-host-key config))
+            #~(string-append "--password-helper=" #$lsh 
"/sbin/lsh-pam-checkpw")
+            #~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server")
+            "-p" (number->string (lsh-configuration-port-number config))
+            (if (lsh-configuration-password-authentication? config)
+                "--password" "--no-password")
+            (if (lsh-configuration-public-key-authentication? config)
+                "--publickey" "--no-publickey")
+            (if (lsh-configuration-root-login? config)
+                "--root-login" "--no-root-login")
+            (if (lsh-configuration-x11-forwarding? config)
+                "--x11-forward" "--no-x11-forward")
+            (if (lsh-configuration-tcp/ip-forwarding? config)
+                "--tcpip-forward" "--no-tcpip-forward")
+            (if (null? interfaces)
+                '()
+                (list (string-append "--interfaces="
+                                     (string-join interfaces ",")))))))
+
+  (define requires
+    (if (and daemonic? (lsh-configuration-syslog-output? config))
+        '(networking syslogd)
+        '(networking)))
+
+  (list (dmd-service
+         (documentation "GNU lsh SSH server")
+         (provision '(ssh-daemon))
+         (requirement requires)
+         (start #~(make-forkexec-constructor (list address@hidden)))
+         (stop  #~(make-kill-destructor)))))
+
+(define (lsh-pam-services config)
+  "Return a list of <pam-services> for lshd with CONFIG."
+  (list (unix-pam-service
+         "lshd"
+         #:allow-empty-passwords?
+         (lsh-configuration-allow-empty-passwords? config))))
+
+(define lsh-service-type
+  (service-type (name 'lsh)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          lsh-dmd-service)
+                       (service-extension pam-root-service-type
+                                          lsh-pam-services)
+                       (service-extension activation-service-type
+                                          lsh-activation)))))
+
 (define* (lsh-service #:key
                       (lsh lsh)
                       (daemonic? #t)
@@ -114,58 +204,21 @@ passwords, and @var{root-login?} specifies whether to 
accept log-ins as
 root.
 
 The other options should be self-descriptive."
-  (define lsh-command
-    (append
-     (cons #~(string-append #$lsh "/sbin/lshd")
-           (if daemonic?
-               (let ((syslog (if syslog-output? '()
-                                 (list "--no-syslog"))))
-                 (cons "--daemonic"
-                       (if pid-file?
-                           (cons #~(string-append "--pid-file=" #$pid-file)
-                                 syslog)
-                           (cons "--no-pid-file" syslog))))
-               (if pid-file?
-                   (list #~(string-append "--pid-file=" #$pid-file))
-                   '())))
-     (cons* #~(string-append "--host-key=" #$host-key)
-            #~(string-append "--password-helper=" #$lsh 
"/sbin/lsh-pam-checkpw")
-            #~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server")
-            "-p" (number->string port-number)
-            (if password-authentication? "--password" "--no-password")
-            (if public-key-authentication?
-                "--publickey" "--no-publickey")
-            (if root-login?
-                "--root-login" "--no-root-login")
-            (if x11-forwarding?
-                "--x11-forward" "--no-x11-forward")
-            (if tcp/ip-forwarding?
-                "--tcpip-forward" "--no-tcpip-forward")
-            (if (null? interfaces)
-                '()
-                (list (string-append "--interfaces="
-                                     (string-join interfaces ",")))))))
-
-  (define requires
-    (if (and daemonic? syslog-output?)
-        '(networking syslogd)
-        '(networking)))
-
-  (service
-   (documentation "GNU lsh SSH server")
-   (provision '(ssh-daemon))
-   (requirement requires)
-   (start #~(make-forkexec-constructor (list address@hidden)))
-   (stop  #~(make-kill-destructor))
-   (pam-services
-    (list (unix-pam-service
-           "lshd"
-           #:allow-empty-passwords? allow-empty-passwords?)))
-   (activate #~(begin
-                 (use-modules (guix build utils))
-                 (mkdir-p "/var/spool/lsh")
-                 #$(if initialize?
-                       (activation lsh host-key)
-                       #t)))))
+  (service (type lsh-service-type)
+           (parameters
+            (lsh-configuration (lsh lsh) (daemonic? daemonic?)
+                               (host-key host-key) (interfaces interfaces)
+                               (port-number port-number)
+                               (allow-empty-passwords? allow-empty-passwords?)
+                               (root-login? root-login?)
+                               (syslog-output? syslog-output?)
+                               (pid-file? pid-file?) (pid-file pid-file)
+                               (x11-forwarding? x11-forwarding?)
+                               (tcp/ip-forwarding? tcp/ip-forwarding?)
+                               (password-authentication?
+                                password-authentication?)
+                               (public-key-authentication?
+                                public-key-authentication?)
+                               (initialize? initialize?)))))
 
 ;;; ssh.scm ends here
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index 9c96aab..6da4451 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -20,6 +20,7 @@
 (define-module (gnu services xorg)
   #:use-module (gnu artwork)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
   #:use-module (gnu system linux)                 ; 'pam-service'
   #:use-module ((gnu packages base) #:select (canonical-package))
   #:use-module (gnu packages guile)
@@ -212,6 +213,81 @@ which should be passed to this script as the first 
argument.  If not, the
   ;; contains the actual theme files.
   "0.x")
 
+(define-record-type† slim-configuration
+  (slim slim)
+  allow-empty-passwords? auto-login? default-user theme theme-name
+  (xauth xauth) (dmd dmd) (bash bash)
+  auto-login-session startx)
+
+(define (slim-pam-service config)
+  "Return a PAM service for @command{slim}."
+  (list (unix-pam-service
+         "slim"
+         #:allow-empty-passwords?
+         (slim-configuration-allow-empty-passwords? config))))
+
+(define (slim-dmd-service config)
+  (define slim.cfg
+    (let ((xinitrc (xinitrc #:fallback-session
+                            (slim-configuration-auto-login-session config)))
+          (xauth   (slim-configuration-xauth config))
+          (startx  (slim-configuration-startx config))
+          (dmd     (slim-configuration-dmd config))
+          (theme-name (slim-configuration-theme-name config)))
+      (mixed-text-file "slim.cfg"  "
+default_path /run/current-system/profile/bin
+default_xserver " startx "
+xserver_arguments :0 vt7
+xauth_path " xauth "/bin/xauth
+authfile /var/run/slim.auth
+
+# The login command.  '%session' is replaced by the chosen session name, one
+# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc.
+login_cmd  exec " xinitrc " %session
+sessiondir /run/current-system/profile/share/xsessions
+session_msg session (F1 to change):
+
+halt_cmd " dmd "/sbin/halt
+reboot_cmd " dmd "/sbin/reboot\n"
+(if (slim-configuration-auto-login? config)
+    (string-append "auto_login yes\ndefault_user "
+                   (slim-configuration-default-user config) "\n")
+    "")
+(if theme-name
+    (string-append "current_theme " theme-name "\n")
+    ""))))
+
+  (define theme
+    (slim-configuration-theme config))
+
+  (list (dmd-service
+         (documentation "Xorg display server")
+         (provision '(xorg-server))
+         (requirement '(user-processes host-name udev))
+         (start
+          #~(lambda ()
+              ;; A stale lock file can prevent SLiM from starting, so remove 
it to
+              ;; be on the safe side.
+              (false-if-exception (delete-file "/var/run/slim.lock"))
+
+              (fork+exec-command
+               (list (string-append #$slim "/bin/slim") "-nodaemon")
+               #:environment-variables
+               (list (string-append "SLIM_CFGFILE=" #$slim.cfg)
+                     #$@(if theme
+                            (list #~(string-append "SLIM_THEMESDIR=" #$theme))
+                            #~())))))
+         (stop #~(make-kill-destructor))
+         (respawn? #t))))
+
+(define slim-service-type
+  (service-type (name 'slim)
+                (extensions
+                 (list (service-extension dmd-root-service-type
+                                          slim-dmd-service)
+                       (service-extension pam-root-service-type
+                                          slim-pam-service)))))
+
 (define* (slim-service #:key (slim slim)
                        (allow-empty-passwords? #t) auto-login?
                        (default-user "")
@@ -246,54 +322,14 @@ If @var{theme} is @code{#f}, the use the default log-in 
theme; otherwise
 @var{theme} must be a gexp denoting the name of a directory containing the
 theme to use.  In that case, @var{theme-name} specifies the name of the
 theme."
-
-  (define slim.cfg
-    (let ((xinitrc (xinitrc #:fallback-session auto-login-session)))
-      (mixed-text-file "slim.cfg"  "
-default_path /run/current-system/profile/bin
-default_xserver " startx "
-xserver_arguments :0 vt7
-xauth_path " xauth "/bin/xauth
-authfile /var/run/slim.auth
-
-# The login command.  '%session' is replaced by the chosen session name, one
-# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc.
-login_cmd  exec " xinitrc " %session
-sessiondir /run/current-system/profile/share/xsessions
-session_msg session (F1 to change):
-
-halt_cmd " dmd "/sbin/halt
-reboot_cmd " dmd "/sbin/reboot\n"
-            (if auto-login?
-                (string-append "auto_login yes\ndefault_user " default-user 
"\n")
-                "")
-            (if theme-name
-                (string-append "current_theme " theme-name "\n")
-               ""))))
-
-  (service
-   (documentation "Xorg display server")
-   (provision '(xorg-server))
-   (requirement '(user-processes host-name udev))
-   (start
-    #~(lambda ()
-        ;; A stale lock file can prevent SLiM from starting, so remove it
-        ;; to be on the safe side.
-        (false-if-exception (delete-file "/var/run/slim.lock"))
-
-        (fork+exec-command
-         (list (string-append #$slim "/bin/slim") "-nodaemon")
-         #:environment-variables
-         (list (string-append "SLIM_CFGFILE=" #$slim.cfg)
-               #$@(if theme
-                      (list #~(string-append "SLIM_THEMESDIR=" #$theme))
-                      #~())))))
-   (stop #~(make-kill-destructor))
-   (respawn? #t)
-   (pam-services
-    ;; Tell PAM about 'slim'.
-    (list (unix-pam-service
-           "slim"
-           #:allow-empty-passwords? allow-empty-passwords?)))))
+  (service (type slim-service-type)
+           (parameters (slim-configuration
+                        (slim slim)
+                        (allow-empty-passwords? allow-empty-passwords?)
+                        (auto-login? auto-login?) (default-user default-user)
+                        (theme theme) (theme-name theme-name)
+                        (xauth xauth) (dmd dmd) (bash bash)
+                        (auto-login-session auto-login-session)
+                        (startx startx)))))
 
 ;;; xorg.scm ends here
diff --git a/gnu/system.scm b/gnu/system.scm
index 5eaafed..70a48bf 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -87,8 +87,6 @@
             operating-system-locale-directory
             operating-system-boot-script
 
-            file-union
-
             local-host-aliases
             %setuid-programs
             %base-packages
@@ -162,41 +160,6 @@
 
 
 ;;;
-;;; Derivation.
-;;;
-
-(define* (file-union name files)
-  "Return a derivation that builds a directory containing all of FILES.  Each
-item in FILES must be a list where the first element is the file name to use
-in the new directory, and the second element is a gexp denoting the target
-file."
-  (define builder
-    #~(begin
-        (mkdir #$output)
-        (chdir #$output)
-        #$@(map (match-lambda
-                 ((target source)
-                  #~(symlink #$source #$target)))
-                files)))
-
-  (gexp->derivation name builder))
-
-(define (directory-union name things)
-  "Return a directory that is the union of THINGS."
-  (match things
-    ((one)
-     ;; Only one thing; return it.
-     (with-monad %store-monad (return one)))
-    (_
-     (gexp->derivation name
-                       #~(begin
-                           (use-modules (guix build union))
-                           (union-build #$output '#$things))
-                       #:modules '((guix build union))
-                       #:local-build? #t))))
-
-
-;;;
 ;;; Services.
 ;;;
 
@@ -244,18 +207,7 @@ as 'needed-for-boot'."
                                   (string->symbol (mapped-device-target md))))
                  (device-mappings fs))))
 
-  (map (lambda (fs)
-         (match fs
-           (($ <file-system> device title target type flags opts
-                             #f check? create?)
-            (file-system-service device target type
-                                 #:title title
-                                 #:requirements (requirements fs)
-                                 #:check? check?
-                                 #:create-mount-point? create?
-                                 #:options opts
-                                 #:flags flags))))
-       file-systems))
+  (map file-system-service file-systems))
 
 (define (mapped-device-user device file-systems)
   "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
@@ -315,10 +267,20 @@ bookkeeping."
          (unmount   (user-unmount-service known-fs))
          (swaps     (swap-services os))
          (procs     (user-processes-service
-                     (map (compose first service-provision)
-                          other-fs)))
+                     (map service-parameters other-fs)))
          (host-name (host-name-service (operating-system-host-name os))))
-    (cons* host-name procs root-fs unmount
+    (cons* %boot-service
+
+           ;; %DMD-ROOT-SERVICE must come first so that the gexp that execs
+           ;; dmd comes last in the boot script (XXX).
+           %dmd-root-service %activation-service
+
+           (pam-root-service (operating-system-pam-services os))
+           (account-service (append (operating-system-accounts os)
+                                    (operating-system-groups os))
+                            (operating-system-skeletons os))
+           (operating-system-etc-service os)
+           host-name procs root-fs unmount
            (append other-fs mappings swaps))))
 
 (define (operating-system-services os)
@@ -437,29 +399,24 @@ on SHELLS.  /etc/shells is used by xterm, polkit, and 
other programs."
                                         (newline port))
                                       shells))))))
 
-(define* (etc-directory #:key
-                        (locale "C") (timezone "Europe/Paris")
-                        (issue "Hello!\n")
-                        (skeletons '())
-                        (pam-services '())
-                        (profile "/run/current-system/profile")
-                        hosts-file nss (shells '())
-                        (sudoers-file (plain-file "sudoers" "")))
-  "Return a derivation that builds the static part of the /etc directory."
-  (mlet* %store-monad
-      ((pam.d ->   (pam-services->directory pam-services))
-       (login.defs (text-file "login.defs" "# Empty for now.\n"))
-       (shells     (shells-file shells))
-       (emacs      (emacs-site-directory))
-       (issue      (text-file "issue" issue))
-       (nsswitch   (text-file "nsswitch.conf"
-                              (name-service-switch->string nss)))
+(define* (operating-system-etc-service os)
+  "Return a <service> that builds containing the static part of the /etc
+directory."
+  (let
+      ((login.defs (plain-file "login.defs" "# Empty for now.\n"))
+       ;; FIXME: These two are missing.
+       ;; (shells     (shells-file shells))
+       ;; (emacs      (emacs-site-directory))
+       (issue      (plain-file "issue" (operating-system-issue os)))
+       (nsswitch   (plain-file "nsswitch.conf"
+                               (name-service-switch->string
+                                (operating-system-name-service-switch os))))
 
        ;; Startup file for POSIX-compliant login shells, which set system-wide
        ;; environment variables.
-       (profile    (text-file* "profile"  "\
-export LANG=\"" locale "\"
-export TZ=\"" timezone "\"
+       (profile    (mixed-text-file "profile"  "\
+export LANG=\"" (operating-system-locale os) "\"
+export TZ=\"" (operating-system-timezone os) "\"
 export TZDIR=\"" tzdata "/share/zoneinfo\"
 
 # Tell 'modprobe' & co. where to look for modules.
@@ -516,7 +473,7 @@ then
 fi
 "))
 
-       (bashrc    (text-file "bashrc" "\
+       (bashrc    (plain-file "bashrc" "\
 # Bash-specific initialization.
 
 # The 'bash-completion' package.
@@ -526,25 +483,23 @@ then
   # completion loader that searches its own completion files as well
   # as those in ~/.guix-profile and /run/current-system/profile.
   source /run/current-system/profile/etc/profile.d/bash_completion.sh
-fi\n"))
-       (skel ->   (skeleton-directory skeletons)))
-    (file-union "etc"
-                `(("services" ,#~(string-append #$net-base "/etc/services"))
-                  ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
-                  ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
-                  ("emacs" ,#~#$emacs)
-                  ("pam.d" ,#~#$pam.d)
-                  ("login.defs" ,#~#$login.defs)
-                  ("issue" ,#~#$issue)
-                  ("nsswitch.conf" ,#~#$nsswitch)
-                  ("skel" ,#~#$skel)
-                  ("shells" ,#~#$shells)
-                  ("profile" ,#~#$profile)
-                  ("bashrc" ,#~#$bashrc)
-                  ("hosts" ,#~#$hosts-file)
-                  ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
-                                                 #$timezone))
-                  ("sudoers" ,sudoers-file)))))
+fi\n")))
+    (etc-service
+     `(("services" ,#~(string-append #$net-base "/etc/services"))
+       ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
+       ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
+       ;; ("emacs" ,#~#$emacs)
+       ("login.defs" ,#~#$login.defs)
+       ("issue" ,#~#$issue)
+       ("nsswitch.conf" ,#~#$nsswitch)
+       ;; ("shells" ,#~#$shells)
+       ("profile" ,#~#$profile)
+       ("bashrc" ,#~#$bashrc)
+       ("hosts" ,#~#$(or (operating-system-hosts-file os)
+                         (default-/etc/hosts (operating-system-host-name os))))
+       ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
+                                      #$(operating-system-timezone os)))
+       ("sudoers" ,(operating-system-sudoers-file os))))))
 
 (define (operating-system-profile os)
   "Return a derivation that builds the system profile of OS."
@@ -570,9 +525,7 @@ fi\n"))
         (operating-system-users os)
         (cons %root-account (operating-system-users os))))
 
-  (append users
-          (append-map service-user-accounts
-                      (operating-system-services os))))
+  users)
 
 (define (maybe-string->file file-name thing)
   "If THING is a string, return a <plain-file> with THING as its content.
@@ -607,31 +560,9 @@ use 'plain-file' instead~%")
 
 (define (operating-system-etc-directory os)
   "Return that static part of the /etc directory of OS."
-  (mlet* %store-monad
-      ((services -> (operating-system-services os))
-       (pam-services ->
-                     ;; Services known to PAM.
-                     (append (operating-system-pam-services os)
-                             (append-map service-pam-services services)))
-       (profile-drv (operating-system-profile os))
-       (skeletons   (operating-system-skeletons os))
-       (/etc/hosts  (maybe-file->monadic
-                     "hosts"
-                     (or (operating-system-hosts-file os)
-                         (default-/etc/hosts (operating-system-host-name 
os)))))
-       (shells ->   (user-shells os)))
-   (etc-directory #:pam-services pam-services
-                  #:skeletons skeletons
-                  #:issue (operating-system-issue os)
-                  #:locale (operating-system-locale os)
-                  #:nss (operating-system-name-service-switch os)
-                  #:timezone (operating-system-timezone os)
-                  #:hosts-file /etc/hosts
-                  #:shells shells
-                  #:sudoers-file (maybe-string->file
-                                  "sudoers"
-                                  (operating-system-sudoers-file os))
-                  #:profile profile-drv)))
+  (etc-directory
+   (fold-services (operating-system-services os)
+                  #:target-type etc-service-type)))
 
 (define %setuid-programs
   ;; Default set of setuid-root programs.
@@ -652,176 +583,13 @@ use 'plain-file' instead~%")
 root ALL=(ALL) ALL
 %wheel ALL=(ALL) ALL\n"))
 
-(define (user-group->gexp group)
-  "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
-'active-groups'."
-  #~(list #$(user-group-name group)
-          #$(user-group-password group)
-          #$(user-group-id group)
-          #$(user-group-system? group)))
-
-(define (user-account->gexp account)
-  "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
-'activate-users'."
-  #~`(#$(user-account-name account)
-      #$(user-account-uid account)
-      #$(user-account-group account)
-      #$(user-account-supplementary-groups account)
-      #$(user-account-comment account)
-      #$(user-account-home-directory account)
-      ,#$(user-account-shell account)             ; this one is a gexp
-      #$(user-account-password account)
-      #$(user-account-system? account)))
-
-(define (modprobe-wrapper)
-  "Return a wrapper for the 'modprobe' command that knows where modules live.
-
-This wrapper is typically invoked by the Linux kernel ('call_modprobe', in
-kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment
-variable is not set---hence the need for this wrapper."
-  (let ((modprobe "/run/current-system/profile/bin/modprobe"))
-    (gexp->script "modprobe"
-                  #~(begin
-                      (setenv "LINUX_MODULE_DIRECTORY"
-                              "/run/booted-system/kernel/lib/modules")
-                      (apply execl #$modprobe
-                             (cons #$modprobe (cdr (command-line))))))))
-
-(define* (operating-system-activation-script os #:key container?)
-  "Return the activation script for OS---i.e., the code that \"activates\" the
-stateful part of OS, including user accounts and groups, special directories,
-etc."
-  (define %modules
-    '((gnu build activation)
-      (gnu build linux-boot)
-      (gnu build linux-modules)
-      (gnu build file-systems)
-      (guix build utils)
-      (guix build syscalls)
-      (guix elf)))
-
-  (define (service-activations services)
-    ;; Return the activation scripts for SERVICES.
-    (let ((gexps (filter-map service-activate services)))
-      (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>)
-                                  gexps))))
-
-  (mlet* %store-monad ((services -> (operating-system-services os))
-                       (actions  (service-activations services))
-                       (etc      (operating-system-etc-directory os))
-                       (modules  (imported-modules %modules))
-                       (compiled (compiled-modules %modules))
-                       (modprobe (modprobe-wrapper))
-                       (firmware (directory-union
-                                  "firmware" (operating-system-firmware os)))
-                       (accounts -> (operating-system-accounts os)))
-    (define setuid-progs
-      (operating-system-setuid-programs os))
-
-    (define user-specs
-      (map user-account->gexp accounts))
-
-    (define groups
-      (append (operating-system-groups os)
-              (append-map service-user-groups services)))
-
-    (define group-specs
-      (map user-group->gexp groups))
-
-    (assert-valid-users/groups accounts groups)
-
-    (gexp->file "activate"
-                #~(begin
-                    (eval-when (expand load eval)
-                      ;; Make sure 'use-modules' below succeeds.
-                      (set! %load-path (cons #$modules %load-path))
-                      (set! %load-compiled-path
-                            (cons #$compiled %load-compiled-path)))
-
-                    (use-modules (gnu build activation))
-
-                    ;; Make sure /bin/sh is valid and current.
-                    (activate-/bin/sh
-                     (string-append #$(canonical-package bash)
-                                    "/bin/sh"))
-
-                    ;; Populate /etc.
-                    (activate-etc #$etc)
-
-                    ;; Add users and user groups.
-                    (setenv "PATH"
-                            (string-append #$(@ (gnu packages admin) shadow)
-                                           "/sbin"))
-                    (activate-users+groups (list address@hidden)
-                                           (list address@hidden))
-
-                    ;; Activate setuid programs.
-                    (activate-setuid-programs (list address@hidden))
-
-                    ;; Tell the kernel to use our 'modprobe' command.
-                    (activate-modprobe #$modprobe)
-
-                    ;; Tell the kernel where firmware is, unless we are
-                    ;; activating a container.
-                    #$@(if container?
-                           #~()
-                           ;; Tell the kernel where firmware is.
-                           #~((activate-firmware
-                               (string-append #$firmware "/lib/firmware"))
-                              ;; Let users debug their own processes!
-                              (activate-ptrace-attach)))
-
-                    ;; Run the services' activation snippets.
-                    ;; TODO: Use 'load-compiled'.
-                    (for-each primitive-load '#$actions)
-
-                    ;; Set up /run/current-system.
-                    (activate-current-system)))))
-
-(define* (operating-system-boot-script os #:key container?)
+(define* (operating-system-boot-script os)
   "Return the boot script for OS---i.e., the code started by the initrd once
 we're running in the final root.  When CONTAINER? is true, skip all
 hardware-related operations as necessary when booting a Linux container."
-  (mlet* %store-monad ((services -> (operating-system-services os))
-                       (activate (operating-system-activation-script os))
-                       (dmd-conf (dmd-configuration-file services)))
-    (gexp->file "boot"
-                #~(begin
-                    (use-modules (guix build utils))
-
-                    ;; Clean out /tmp and /var/run.
-                    ;;
-                    ;; XXX This needs to happen before service activations, so
-                    ;; it has to be here, but this also implicitly assumes
-                    ;; that /tmp and /var/run are on the root partition.
-                    (false-if-exception (delete-file-recursively "/tmp"))
-                    (false-if-exception (delete-file-recursively "/var/run"))
-                    (false-if-exception (mkdir "/tmp"))
-                    (false-if-exception (chmod "/tmp" #o1777))
-                    (false-if-exception (mkdir "/var/run"))
-                    (false-if-exception (chmod "/var/run" #o755))
-
-                    ;; Activate the system.
-                    ;; TODO: Use 'load-compiled'.
-                    (primitive-load #$activate)
-
-                    ;; Keep track of the booted system.
-                    (false-if-exception (delete-file "/run/booted-system"))
-                    (symlink (readlink "/run/current-system")
-                             "/run/booted-system")
-
-                    ;; Close any remaining open file descriptors to be on the
-                    ;; safe side.  This must be the very last thing we do,
-                    ;; because Guile has internal FDs such as 'sleep_pipe'
-                    ;; that need to be alive.
-                    (let loop ((fd 3))
-                      (when (< fd 1024)
-                        (false-if-exception (close-fdes fd))
-                        (loop (+ 1 fd))))
-
-                    ;; Start dmd.
-                    (execl (string-append #$dmd "/bin/dmd")
-                           "dmd" "--config" #$dmd-conf)))))
+  (let ((boot (fold-services (operating-system-services os))))
+    ;; This is the script as a monadic value.
+    (service-parameters boot)))
 
 (define (operating-system-root-file-system os)
   "Return the root file system of OS."
@@ -908,19 +676,20 @@ this file is the reconstruction of GRUB menu entries for 
old configurations."
   "Return a derivation that builds OS."
   (mlet* %store-monad
       ((profile     (operating-system-profile os))
-       (etc         (operating-system-etc-directory os))
+       (etc ->      (operating-system-etc-directory os))
        (boot        (operating-system-boot-script os))
        (kernel  ->  (operating-system-kernel os))
        (initrd      (operating-system-initrd-file os))
        (locale      (operating-system-locale-directory os))
        (params      (operating-system-parameters-file os)))
-    (file-union "system"
-                `(("boot" ,#~#$boot)
-                  ("kernel" ,#~#$kernel)
-                  ("parameters" ,#~#$params)
-                  ("initrd" ,initrd)
-                  ("profile" ,#~#$profile)
-                  ("locale" ,#~#$locale)          ;used by libc
-                  ("etc" ,#~#$etc)))))
+    (lower-object
+     (file-union "system"
+                 `(("boot" ,#~#$boot)
+                   ("kernel" ,#~#$kernel)
+                   ("parameters" ,#~#$params)
+                   ("initrd" ,initrd)
+                   ("profile" ,#~#$profile)
+                   ("locale" ,#~#$locale)         ;used by libc
+                   ("etc" ,#~#$etc))))))
 
 ;;; system.scm ends here
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index bbfa234..80e5bab 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -154,35 +154,39 @@ current store is on a RAM disk."
                (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE)
                (rmdir "/.rw-store"))))))
 
+(define cow-store-service-type
+  (dmd-service-type
+   (lambda _
+     (dmd-service
+      (requirement '(root-file-system user-processes))
+      (provision '(cow-store))
+      (documentation
+       "Make the store copy-on-write, with writes going to \
+the given target.")
+
+      ;; This is meant to be explicitly started by the user.
+      (auto-start? #f)
+
+      (start #~(case-lambda
+                 ((target)
+                  #$(make-cow-store #~target)
+                  target)
+                 (else
+                  ;; Do nothing, and mark the service as stopped.
+                  #f)))
+      (stop #~(lambda (target)
+                ;; Delete the temporary directory, but leave everything
+                ;; mounted as there may still be processes using it since
+                ;; 'user-processes' doesn't depend on us.  The 'user-unmount'
+                ;; service will unmount TARGET eventually.
+                (delete-file-recursively
+                 (string-append target #$%backing-directory))))))))
+
 (define (cow-store-service)
   "Return a service that makes the store copy-on-write, such that writes go to
 the user's target storage device rather than on the RAM disk."
   ;; See <http://bugs.gnu.org/18061> for the initial report.
-  (service
-   (requirement '(root-file-system user-processes))
-   (provision '(cow-store))
-   (documentation
-    "Make the store copy-on-write, with writes going to \
-the given target.")
-
-   ;; This is meant to be explicitly started by the user.
-   (auto-start? #f)
-
-   (start #~(case-lambda
-              ((target)
-               #$(make-cow-store #~target)
-               target)
-              (else
-               ;; Do nothing, and mark the service as stopped.
-               #f)))
-   (stop #~(lambda (target)
-             ;; Delete the temporary directory, but leave everything
-             ;; mounted as there may still be processes using it
-             ;; since 'user-processes' doesn't depend on us.  The
-             ;; 'user-unmount' service will unmount TARGET
-             ;; eventually.
-             (delete-file-recursively
-              (string-append target #$%backing-directory))))))
+  (service (type cow-store-service-type)))
 
 (define (configuration-template-service)
   "Return a dummy service whose purpose is to install an operating system
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
index 10e72e9..4696620 100644
--- a/gnu/system/linux.scm
+++ b/gnu/system/linux.scm
@@ -20,6 +20,7 @@
   #:use-module (guix records)
   #:use-module (guix derivations)
   #:use-module (guix gexp)
+  #:use-module (gnu services)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -28,7 +29,10 @@
             pam-entry
             pam-services->directory
             unix-pam-service
-            base-pam-services))
+            base-pam-services
+
+            pam-root-service-type
+            pam-root-service))
 
 ;;; Commentary:
 ;;;
@@ -98,8 +102,8 @@ dumped in /etc/pam.d/NAME, where NAME is the name of 
SERVICE."
 
           (mkdir #$output)
           (for-each (match-lambda
-                     ((name file)
-                      (symlink file (string-append #$output "/" name))))
+                      ((name file)
+                       (symlink file (string-append #$output "/" name))))
 
                     ;; Since <pam-service> objects cannot be compared with
                     ;; 'equal?' since they contain gexps, which contain
@@ -188,4 +192,25 @@ authenticate to run COMMAND."
                '("useradd" "userdel" "usermod"
                  "groupadd" "groupdel" "groupmod"))))
 
+
+;;;
+;;; PAM root service.
+;;;
+
+(define (/etc-entry services)
+  `(("pam.d" ,(pam-services->directory services))))
+
+(define pam-root-service-type
+  (service-type (name 'pam)
+                (extensions (list (service-extension etc-service-type
+                                                     /etc-entry)))
+                (compose concatenate)
+                (extend append)))
+
+(define (pam-root-service base)
+  "The \"root\" PAM service, which collects <pam-service> instance and turns
+them into a /etc/pam.d directory, including the <pam-service> listed in BASE."
+  (service (type pam-root-service-type)
+           (parameters base)))
+
 ;;; linux.scm ends here
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index ddd5f66..b0feda5 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -22,12 +22,14 @@
   #:use-module (guix store)
   #:use-module (guix sets)
   #:use-module (guix ui)
+  #:use-module (gnu services)
   #:use-module ((gnu system file-systems)
                 #:select (%tty-gid))
   #:use-module ((gnu packages admin)
                 #:select (shadow))
   #:use-module (gnu packages bash)
   #:use-module (gnu packages guile-wm)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -54,7 +56,9 @@
             skeleton-directory
             %base-groups
             %base-user-accounts
-            assert-valid-users/groups))
+
+            account-service-type
+            account-service))
 
 ;;; Commentary:
 ;;;
@@ -87,31 +91,42 @@
   (system?        user-group-system?              ; Boolean
                   (default #f)))
 
+;; Configuration of the whole user account system.
+(define-record-type* <account-configuration>
+  account-configuration make-account-configuration
+  account-configuration?
+  (users         account-configuration-users)
+  (groups        account-configuration-groups)
+  (skeletons     account-configuration-skeletons
+                 (default (default-skeletons)))
+  (shadow        account-configuration-shadow
+                 (default (@ (gnu packages admin) shadow))))
+
 (define %base-groups
   ;; Default set of groups.
   (let-syntax ((system-group (syntax-rules ()
                                ((_ args ...)
                                 (user-group (system? #t) args ...)))))
     (list (system-group (name "root") (id 0))
-          (system-group (name "wheel"))              ; root-like users
-          (system-group (name "users"))              ; normal users
-          (system-group (name "nogroup"))            ; for daemons etc.
+          (system-group (name "wheel"))           ; root-like users
+          (system-group (name "users"))           ; normal users
+          (system-group (name "nogroup"))         ; for daemons etc.
 
           ;; The following groups are conventionally used by things like udev 
to
           ;; control access to hardware devices.
           (system-group (name "tty") (id %tty-gid))
           (system-group (name "dialout"))
           (system-group (name "kmem"))
-          (system-group (name "input"))              ; input devices, from udev
+          (system-group (name "input"))           ; input devices, from udev
           (system-group (name "video"))
           (system-group (name "audio"))
-          (system-group (name "netdev"))             ; used in avahi-dbus.conf
+          (system-group (name "netdev"))          ; used in avahi-dbus.conf
           (system-group (name "lp"))
           (system-group (name "disk"))
           (system-group (name "floppy"))
           (system-group (name "cdrom"))
           (system-group (name "tape"))
-          (system-group (name "kvm")))))             ; for /dev/kvm
+          (system-group (name "kvm")))))          ; for /dev/kvm
 
 (define %base-user-accounts
   ;; List of standard user accounts.  Note that "root" is a special case, so
@@ -224,4 +239,81 @@ of user '~a' is undeclared")
                           (user-account-supplementary-groups user)))
               users)))
 
+
+;;;
+;;; Service.
+;;;
+
+(define (user-group->gexp group)
+  "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
+'active-groups'."
+  #~(list #$(user-group-name group)
+          #$(user-group-password group)
+          #$(user-group-id group)
+          #$(user-group-system? group)))
+
+(define (user-account->gexp account)
+  "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
+'activate-users'."
+  #~`(#$(user-account-name account)
+      #$(user-account-uid account)
+      #$(user-account-group account)
+      #$(user-account-supplementary-groups account)
+      #$(user-account-comment account)
+      #$(user-account-home-directory account)
+      ,#$(user-account-shell account)             ; this one is a gexp
+      #$(user-account-password account)
+      #$(user-account-system? account)))
+
+(define (account-activation accounts+groups)
+  "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
+<user-group> objects.  Raise an error if a user account refers to a undefined
+group."
+  (define accounts
+    (filter user-account? accounts+groups))
+
+  (define user-specs
+    (map user-account->gexp accounts))
+
+  (define groups
+    (filter user-group? accounts+groups))
+
+  (define group-specs
+    (map user-group->gexp groups))
+
+  (assert-valid-users/groups accounts groups)
+
+  ;; Add users and user groups.
+  #~(begin
+      (setenv "PATH"
+              (string-append #$(@ (gnu packages admin) shadow) "/sbin"))
+      (activate-users+groups (list address@hidden)
+                             (list address@hidden))))
+
+(define (etc-skel arguments)
+  "Filter out among ARGUMENTS things corresponding to skeletons, and return
+the /etc/skel directory for those."
+  (let ((skels (filter pair? arguments)))
+    `(("skel" ,(skeleton-directory skels)))))
+
+(define account-service-type
+  (service-type (name 'account)
+
+                ;; Concatenate <user-account>, <user-group>, and skeleton
+                ;; lists.
+                (compose concatenate)
+                (extend append)
+
+                (extensions
+                 (list (service-extension activation-service-type
+                                          account-activation)
+                       (service-extension etc-service-type
+                                          etc-skel)))))
+
+(define (account-service accounts+groups skeletons)
+  "Return a <service> that takes care of user accounts and user groups, with
+ACCOUNTS+GROUPS as its initial list of accounts and groups."
+  (service (type account-service-type)
+           (parameters (append skeletons accounts+groups))))
+
 ;;; shadow.scm ends here



reply via email to

[Prev in Thread] Current Thread [Next in Thread]