services: Introduce extensible services.

This patch rewrites GuixSD services to make them extensible.

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

1 files changed, 340 insertions, 206 deletions

diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 50ffac5796..52a843b54b 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,72 @@ fe80::1%lo0 www.connect.facebook.net
 fe80::1%lo0 apps.facebook.com\n")
 
 
+(define-record-type* <static-networking>
+  static-networking make-static-networking
+  static-networking?
+  (interface static-networking-interface)
+  (ip static-networking-ip)
+  (gateway static-networking-gateway)
+  (provision static-networking-provision)
+  (name-servers static-networking-name-servers)
+  (net-tools static-networking-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 +157,70 @@ 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 static-networking-service-type
+           (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 dhcp-client-service-type dhcp))
 
 (define %ntp-servers
   ;; Default set of NTP servers.
@@ -199,19 +228,30 @@ 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
-@uref{http://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.
+;;;
+
+;; TODO: Export.
+(define-record-type* <ntp-configuration>
+  ntp-configuration make-ntp-configuration
+  ntp-configuration?
+  (ntp      ntp-configuration-ntp
+            (default ntp))
+  (servers  ntp-configuration-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 +261,154 @@ 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
+@uref{http://www.ntp.org, Network Time Protocol package}.  The daemon will
+keep the system clock synchronized with that of @var{servers}."
+  (service ntp-service-type
+           (ntp-configuration (ntp ntp) (servers servers))))
+
+
+;;;
+;;; 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-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.")))))
+
+(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 tor-service-type tor))
+
+
+;;;
+;;; BitlBee.
+;;;
+
+(define-record-type* <bitlbee-configuration>
+  bitlbee-configuration make-bitlbee-configuration
+  bitlbee-configuration?
+  (bitlbee bitlbee-configuration-bitlbee
+           (default bitlbee))
+  (interface bitlbee-configuration-interface)
+  (port bitlbee-configuration-port)
+  (extra-settings bitlbee-configuration-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))
+        (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 +423,52 @@ 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 bitlbee-service-type
+           (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 wicd-service-type wicd))
 
 ;;; networking.scm ends here