Browse Source

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.
gn-latest-20200428
Ludovic Courtès 5 years ago
parent
commit
0adfe95a3e
24 changed files with 3328 additions and 1689 deletions
  1. +3
    -0
      .gitignore
  2. +1
    -0
      Makefile.am
  3. +2
    -1
      doc.am
  4. +409
    -62
      doc/guix.texi
  5. +35
    -0
      doc/images/service-graph.dot
  6. +1
    -0
      gnu-system.am
  7. +417
    -38
      gnu/services.scm
  8. +82
    -40
      gnu/services/avahi.scm
  9. +595
    -414
      gnu/services/base.scm
  10. +86
    -58
      gnu/services/databases.scm
  11. +178
    -0
      gnu/services/dbus.scm
  12. +354
    -291
      gnu/services/desktop.scm
  13. +77
    -1
      gnu/services/dmd.scm
  14. +57
    -23
      gnu/services/lirc.scm
  15. +340
    -206
      gnu/services/networking.scm
  16. +122
    -56
      gnu/services/ssh.scm
  17. +69
    -39
      gnu/services/web.scm
  18. +99
    -49
      gnu/services/xorg.scm
  19. +127
    -342
      gnu/system.scm
  20. +66
    -59
      gnu/system/install.scm
  21. +27
    -3
      gnu/system/linux.scm
  22. +89
    -7
      gnu/system/shadow.scm
  23. +1
    -0
      po/guix/POTFILES.in
  24. +91
    -0
      tests/services.scm

+ 3
- 0
.gitignore View File

@@ -129,3 +129,6 @@ GTAGS
/doc/images/coreutils-bag-graph.png
/doc/images/coreutils-graph.png
/doc/images/coreutils-size-map.eps
/doc/images/service-graph.png
/doc/images/service-graph.eps
/doc/images/service-graph.pdf

+ 1
- 0
Makefile.am View File

@@ -219,6 +219,7 @@ SCM_TESTS = \
tests/size.scm \
tests/graph.scm \
tests/file-systems.scm \
tests/services.scm \
tests/containers.scm

if HAVE_GUILE_JSON


+ 2
- 1
doc.am View File

@@ -22,7 +22,8 @@ info_TEXINFOS = doc/guix.texi
DOT_FILES = \
doc/images/bootstrap-graph.dot \
doc/images/coreutils-graph.dot \
doc/images/coreutils-bag-graph.dot
doc/images/coreutils-bag-graph.dot \
doc/images/service-graph.dot

DOT_VECTOR_GRAPHICS = \
$(DOT_FILES:%.dot=%.eps) \


+ 409
- 62
doc/guix.texi View File

@@ -182,6 +182,13 @@ Services
* Web Services:: Web servers.
* Various Services:: Other services.

Defining Services

* Service Composition:: The model for composing services.
* Service Types and Services:: Types and services.
* Service Reference:: API reference.
* dmd Services:: A particular type of service.

Packaging Guidelines

* Software Freedom:: What may go into the distribution.
@@ -5899,23 +5906,41 @@ Return a service that runs @code{syslogd}. If configuration file name
settings.
@end deffn

@deffn {Scheme Procedure} guix-service [#:guix guix] @
[#:builder-group "guixbuild"] [#:build-accounts 10] @
[#:authorize-hydra-key? #t] [#:use-substitutes? #t] @
[#:extra-options '()]
Return a service that runs the build daemon from @var{guix}, and has
@var{build-accounts} user accounts available under @var{builder-group}.
@anchor{guix-configuration-type}
@deftp {Data Type} guix-configuration
This data type represents the configuration of the Guix build daemon.
@xref{Invoking guix-daemon}, for more information.

@table @asis
@item @code{guix} (default: @var{guix})
The Guix package to use.

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.
@item @code{build-group} (default: @code{"guixbuild"})
Name of the group for build user accounts.

If @var{use-substitutes?} is false, the daemon is run with
@option{--no-substitutes} (@pxref{Invoking guix-daemon,
@option{--no-substitutes}}).
@item @code{build-accounts} (default: @code{10})
Number of build user accounts to create.

Finally, @var{extra-options} is a list of additional command-line options
passed to @command{guix-daemon}.
@item @code{authorize-key?} (default: @code{#t})
Whether to authorize the substitute key for @code{hydra.gnu.org}
(@pxref{Substitutes}).

@item @code{use-substitutes?} (default: @code{#t})
Whether to use substitutes.

@item @code{extra-options} (default: @code{'()})
List of extra command-line options for @command{guix-daemon}.

@item @code{lsof} (default: @var{lsof})
@itemx @code{lsh} (default: @var{lsh})
The lsof and lsh packages to use.

@end table
@end deftp

@deffn {Scheme Procedure} guix-service @var{config}
Return a service that runs the Guix build daemon according to
@var{config}.
@end deffn

@deffn {Scheme Procedure} udev-service [#:udev udev]
@@ -6179,11 +6204,10 @@ The @var{%desktop-services} variable can be used as the @code{services}
field of an @code{operating-system} declaration (@pxref{operating-system
Reference, @code{services}}).

The actual service definitions provided by @code{(gnu services desktop)}
are described below.
The actual service definitions provided by @code{(gnu services dbus)}
and @code{(gnu services desktop)} are described below.

@deffn {Scheme Procedure} dbus-service @var{services} @
[#:dbus @var{dbus}]
@deffn {Scheme Procedure} dbus-service [#:dbus @var{dbus}] [#:services '()]
Return a service that runs the ``system bus'', using @var{dbus}, with
support for @var{services}.

@@ -6197,8 +6221,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

@deffn {Scheme Procedure} elogind-service @
[#:elogind @var{elogind}] [#:config @var{config}]
@deffn {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
@@ -6957,54 +6980,378 @@ build users.
@node Defining Services
@subsection Defining Services

The @code{(gnu services @dots{})} modules define several procedures that allow
users to declare the operating system's services (@pxref{Using the
Configuration System}). These procedures are @emph{monadic
procedures}---i.e., procedures that return a monadic value in the store
monad (@pxref{The Store Monad}). For examples of such procedures,
@xref{Services}.

@cindex service definition
The monadic value returned by those procedures is a @dfn{service
definition}---a structure as returned by the @code{service} form.
Service definitions specifies the inputs the service depends on, and an
expression to start and stop the service. Behind the scenes, service
definitions are ``translated'' into the form suitable for the
configuration file of dmd, the init system (@pxref{Services,,, dmd, GNU
dmd Manual}).

As an example, here is what the @code{nscd-service} procedure looks
like:
The previous sections how the available services and how one can combine
them in an @code{operating-system} declaration. But how do we define
them in the first place? And what is a service anyway?

@lisp
(define (nscd-service)
(with-monad %store-monad
(return (service
(documentation "Run libc's name service cache daemon.")
(provision '(nscd))
(activate #~(begin
(use-modules (guix build utils))
(mkdir-p "/var/run/nscd")))
(start #~(make-forkexec-constructor
(string-append #$glibc "/sbin/nscd")
"-f" "/dev/null" "--foreground"))
(stop #~(make-kill-destructor))
(respawn? #f)))))
@end lisp
@menu
* Service Composition:: The model for composing services.
* Service Types and Services:: Types and services.
* Service Reference:: API reference.
* dmd Services:: A particular type of service.
@end menu

@node Service Composition
@subsubsection Service Composition

@cindex services
@cindex daemons
Here we define a @dfn{service} as, broadly, something that extends the
operating system's functionality. Often a service is a process---a
@dfn{daemon}---started when the system boots: a secure shell server, a
Web server, the Guix build daemon, etc. Sometimes a service is a daemon
whose execution can be triggered by another daemon---e.g., an FTP server
started by @command{inetd} or a D-Bus service activated by
@command{dbus-daemon}. Occasionally, a service does not map to a
daemon. For instance, the ``account'' service collects user accounts
and makes sure they exist when the system runs; the ``udev'' service
collects device management rules and makes them available to the eudev
daemon; the @file{/etc} service populates the system's @file{/etc}
directory.

GuixSD services are connected by @dfn{extensions}. For instance, the
secure shell service @emph{extends} dmd---GuixSD's initialization system,
running as PID@tie{}1---by giving it the command lines to start and stop
the secure shell daemon (@pxref{Networking Services,
@code{lsh-service}}); the UPower service extends the D-Bus service by
passing it its @file{.service} specification, and extends the udev
service by passing it device management rules (@pxref{Desktop Services,
@code{upower-service}}); the Guix daemon service extends dmd by passing
it the command lines to start and stop the daemon, and extends the
account service by passing it a list of required build user accounts
(@pxref{Base Services}).

All in all, services and their ``extends'' relations form a directed
acyclic graph (DAG). If we represent services as boxes and extensions
as arrows, a typical system might provide something like this:

@image{images/service-graph,,5in,Typical service extension graph.}

At the bottom, we see the @dfn{boot service}, which produces the boot
script that is executed at boot time from the initial RAM disk.

@cindex service types
Technically, developers can define @dfn{service types} to express these
relations. There can be any number of services of a given type on the
system---for instance, a system running two instances of the GNU secure
shell server (lsh) has two instances of @var{lsh-service-type}, with
different parameters.

The following section describes the programming interface for service
types and services.

@node Service Types and Services
@subsubsection Service Types and Services

A @dfn{service type} is a node in the DAG described above. Let us start
with a simple example, the service type for the Guix build daemon
(@pxref{Invoking guix-daemon}):

@example
(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)))))
@end example

@noindent
The @code{activate}, @code{start}, and @code{stop} fields are G-expressions
(@pxref{G-Expressions}). The @code{activate} field contains a script to
run at ``activation'' time; it makes sure that the @file{/var/run/nscd}
directory exists before @command{nscd} is started.
It defines a two things:

@enumerate
@item
A name, whose sole purpose is to make inspection and debugging easier.

@item
A list of @dfn{service extensions}, where each extension designates the
target service type and a procedure that, given the service's
parameters, returns a list of object to extend the service of that type.

Every service type has at least one service extension. The only
exception is the @dfn{boot service type}, which is the ultimate service.
@end enumerate

In this example, @var{guix-service-type} extends three services:

@table @var
@item dmd-root-service-type
The @var{guix-dmd-service} procedure defines how the dmd service is
extended. Namely, it returns a @code{<dmd-service>} object that defines
how @command{guix-daemon} is started and stopped (@pxref{dmd Services}).

@item account-service-type
This extension for this service is computed by @var{guix-accounts},
which returns a list of @code{user-group} and @code{user-account}
objects representing the build user accounts (@pxref{Invoking
guix-daemon}).

@item activation-service-type
Here @var{guix-activation} is a procedure that returns a gexp, which is
a code snippet to run at ``activation time''---e.g., when the service is
booted.
@end table

A service of this type is instantiated like this:

@example
(service guix-service-type
(guix-configuration
(build-accounts 5)
(use-substitutes? #f)))
@end example

The second argument to the @code{service} form is a value representing
the parameters of this specific service instance.
@xref{guix-configuration-type, @code{guix-configuration}}, for
information about the @code{guix-configuration} data type.

@var{guix-service-type} is quite simple because it extends other
services but is not extensible itself.

@c @subsubsubsection Extensible Service Types

The service type for an @emph{extensible} service looks like this:

@example
(define udev-service-type
(service-type (name 'udev)
(extensions
(list (service-extension dmd-root-service-type
udev-dmd-service)))

(compose concatenate) ;concatenate the list of rules
(extend (lambda (config rules)
(match config
(($ <udev-configuration> udev initial-rules)
(udev-configuration
(udev udev) ;the udev package to use
(rules (append initial-rules rules)))))))))
@end example

This is the service type for the
@uref{https://wiki.gentoo.org/wiki/Project:Eudev, eudev device
management daemon}. Compared to the previous example, in addition to an
extension of @var{dmd-root-service-type}, we see two new fields:

@table @code
@item compose
This is the procedure to @dfn{compose} the list of extensions to
services of this type.

Services can extend the udev service by passing it lists of rules; we
compose those extensions simply by concatenating them.

@item extend
This procedure defines how the service's value is @dfn{extended} with
the composition of the extensions.

Udev extensions are composed into a list of rules, but the udev service
value is itself a @code{<udev-configuration>} record. So here, we
extend that record by appending the list of rules is contains to the
list of contributed rules.
@end table

There can be only one instance of an extensible service type such as
@var{udev-service-type}. If there were more, the
@code{service-extension} specifications would be ambiguous.

Still here? The next section provides a reference of the programming
interface for services.

@node Service Reference
@subsubsection Service Reference

We have seen an overview of service types (@pxref{Service Types and
Services}). This section provides a reference on how to manipulate
services and service types. This interface is provided by the
@code{(gnu services)} module.

@deffn {Scheme Procedure} service @var{type} @var{value}
Return a new service of @var{type}, a @code{<service-type>} object (see
below.) @var{value} can be any object; it represents the parameters of
this particular service instance.
@end deffn

@deffn {Scheme Procedure} service? @var{obj}
Return true if @var{obj} is a service.
@end deffn

@deffn {Scheme Procedure} service-kind @var{service}
Return the type of @var{service}---i.e., a @code{<service-type>} object.
@end deffn

@deffn {Scheme Procedure} service-parameters @var{service}
Return the value associated with @var{service}. It represents its
parameters.
@end deffn

Here is an example of how a service is created and manipulated:

@example
(define s
(service nginx-service-type
(nginx-configuration
(nginx nginx)
(log-directory log-directory)
(run-directory run-directory)
(file config-file))))

(service? s)
@result{} #t

(eq? (service-kind s) nginx-service-type)
@result{} #t
@end example

@deftp {Data Type} service-type
@cindex service type
This is the representation of a @dfn{service type} (@pxref{Service Types
and Services}).

@table @asis
@item @code{name}
This is a symbol, used only to simplify inspection and debugging.

@item @code{extensions}
A non-empty list of @code{<service-extension>} objects (see below.)

@item @code{compose} (default: @code{#f})
If this is @code{#f}, then the service type denotes services that cannot
be extended---i.e., services that do not receive ``values'' from other
services.

Otherwise, it must be a one-argument procedure. The procedure is called
by @code{fold-services} and is passed a list of values collected from
extensions. It must return a value that is a valid parameter value for
the service instance.

@item @code{extend} (default: @code{#f})
If this is @code{#f}, services of this type cannot be extended.

Otherwise, it must be a two-argument procedure: @code{fold-services}
calls it, passing it the service's initial value as the first argument
and the result of applying @code{compose} to the extension values as the
second argument.
@end table

@xref{Service Types and Services}, for examples.
@end deftp

@deffn {Scheme Procedure} service-extension @var{target-type} @
@var{compute}
Return a new extension for services of type @var{target-type}.
@var{compute} must be a one-argument procedure: @code{fold-services}
calls it, passing it the value associated with the service that provides
the extension; it must return a valid value for the target service.
@end deffn

@deffn {Scheme Procedure} service-extension? @var{obj}
Return true if @var{obj} is a service extension.
@end deffn

At the core of the service abstraction lies the @code{fold-services}
procedure, which is responsible for ``compiling'' a list of services
down to a single boot script. In essence, it propagates service
extensions down the service graph, updating each node parameters on the
way, until it reaches the root node.

@deffn {Scheme Procedure} fold-services @var{services} @
[#:target-type @var{boot-service-type}]
Fold @var{services} by propagating their extensions down to the root of
type @var{target-type}; return the root service adjusted accordingly.
@end deffn

Lastly, the @code{(gnu services)} module also defines several essential
service types, some of which are listed below.

@defvr {Scheme Variable} boot-service-type
The type of the ``boot service'', which is the root of the service
graph.
@end defvr

@defvr {Scheme Variable} etc-service-type
The type of the @file{/etc} service. This service can be extended by
passing it name/file tuples such as:

@example
(list `("issue" ,(plain-file "issue" "Welcome!\n")))
@end example

In this example, the effect would be to add an @file{/etc/issue} file
pointing to the given file.
@end defvr

@defvr {Scheme Variable} setuid-program-service-type
Type for the ``setuid-program service''. This service collects lists of
executable file names, passed as gexps, and adds them to the set of
setuid-root programs on the system (@pxref{Setuid Programs}).
@end defvr


@node dmd Services
@subsubsection dmd Services

@cindex PID 1
@cindex init system
The @code{(gnu services dmd)} provides a way to define services managed
by GNU@tie{}dmd, which is GuixSD initialization system---the first
process that is started when the system boots, aka. PID@tie{}1
(@pxref{Introduction,,, dmd, GNU dmd Manual}). The
@var{%dmd-root-service} represents PID@tie{}1, of type
@var{dmd-root-service-type}; it can be extended by passing it lists of
@code{<dmd-service>} objects.

@deftp {Data Type} dmd-service
The data type representing a service managed by dmd.

@table @asis
@item @code{provision}
This is a list of symbols denoting what the service provides.

These are the names that may be passed to @command{deco start},
@command{deco status}, and similar commands (@pxref{Invoking deco,,,
dmd, GNU dmd Manual}). @xref{Slots of services, the @code{provides}
slot,, dmd, GNU dmd Manual}, for details.

@item @code{requirements} (default: @code{'()})
List of symbols denoting the dmd services this one depends on.

@item @code{respawn?} (default: @code{#t})
Whether to restart the service when it stops, for instance when the
underlying process dies.

@item @code{start}
@itemx @code{stop} (default: @code{#~(const #f)})
The @code{start} and @code{stop} fields refer to dmd's facilities to
start and stop processes (@pxref{Service De- and Constructors,,, dmd,
GNU dmd Manual}). The @code{provision} field specifies the name under
which this service is known to dmd, and @code{documentation} specifies
on-line documentation. Thus, the commands @command{deco start ncsd},
@command{deco stop nscd}, and @command{deco doc nscd} will do what you
would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}).
GNU dmd Manual}). They are given as G-expressions that get expanded in
the dmd configuration file (@pxref{G-Expressions}).

@item @code{documentation}
A documentation string, as shown when running:

@example
deco doc @var{service-name}
@end example

where @var{service-name} is one of the symbols in @var{provision}
(@pxref{Invoking deco,,, dmd, GNU dmd Manual}).
@end table
@end deftp

@defvr {Scheme Variable} dmd-root-service-type
The service type for the dmd ``root service''---i.e., PID@tie{}1.

This is the service type that extensions target when they want to create
dmd services (@pxref{Service Types and Services}, for an example). Each
extension must pass a list of @code{<dmd-service>}.
@end defvr

@defvr {Scheme Variable} %dmd-root-service
This service represents PID@tie{}1.
@end defvr


@node Installing Debugging Files


+ 35
- 0
doc/images/service-graph.dot View File

@@ -0,0 +1,35 @@
digraph "Service Type Dependencies" {
dmd [shape = box, fontname = Helvetica];
pam [shape = box, fontname = Helvetica];
etc [shape = box, fontname = Helvetica];
accounts [shape = box, fontname = Helvetica];
activation [shape = box, fontname = Helvetica];
boot [shape = house, fontname = Helvetica];
lshd -> dmd;
lshd -> pam;
udev -> dmd;
nscd -> dmd [label = "extends"];
"nss-mdns" -> nscd;
"kvm-rules" -> udev;
colord -> udev;
dbus -> dmd;
colord -> dbus;
upower -> udev;
upower -> dbus;
polkit -> dbus;
polkit -> pam;
elogind -> dbus;
elogind -> udev;
elogind -> polkit [label = "extends"];
dmd -> boot;
colord -> accounts;
accounts -> activation;
accounts -> etc;
etc -> activation;
activation -> boot;
pam -> etc;
elogind -> pam;
guix -> dmd;
guix -> activation;
guix -> accounts;
}

+ 1
- 0
gnu-system.am View File

@@ -348,6 +348,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 \


+ 417
- 38
gnu/services.scm View File

@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,49 +18,428 @@

(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 (guix ui)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#: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

service-error?
missing-target-service-error?
missing-target-service-error-service
missing-target-service-error-target-type
ambiguous-target-service-error?
ambiguous-target-service-error-service
ambiguous-target-service-error-target-type

boot-service-type
activation-service-type
activation-service->script
etc-service-type
etc-directory
setuid-program-service-type
firmware-service-type

%boot-service
%activation-service
etc-service

file-union)) ;XXX: for lack of a better place

;;; Comment:
;;;
;;; This module defines a broad notion of "service types" and "services."
;;;
;;; System services as cajoled by dmd.
;;; A service type describe how its instances extend instances of other
;;; service types. For instance, some services extend the instance of
;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
;;; others extend DMD-ROOT-SERVICE-TYPE by passing it instances of
;;; <dmd-service>.
;;;
;;; When applicable, the service type defines how it can itself be extended,
;;; by providing one procedure to compose extensions, and one procedure to
;;; extend itself.
;;;
;;; A notable service type is BOOT-SERVICE-TYPE, which has a single instance,
;;; %BOOT-SERVICE. %BOOT-SERVICE constitutes the root of the service DAG. It
;;; produces the boot script that the initrd loads.
;;;
;;; The 'fold-services' procedure can be passed a list of procedures, which it
;;; "folds" by propagating extensions down the graph; it returns the root
;;; service after the applying all its extensions.
;;;
;;; Code:

(define-record-type* <service>
service make-service
(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>

;; 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)

;; Services of a given type.
(define-record-type <service>
(service type parameters)
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)))
(type service-kind)
(parameters service-parameters))



;;;
;;; Core services.
;;;

(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.
#$@gexps))))

(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'. It is the only service that extends nothing.
(service-type (name 'boot)
(extensions '())
(compose compute-boot-script)
(extend second-argument)))

(define %boot-service
;; This is the ultimate service, the root of the service DAG.
(service boot-service-type #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-service->script service)
"Return as a monadic value the activation script for SERVICE, a service of
ACTIVATION-SCRIPT-TYPE."
(activation-script (service-parameters service)))

(define (activation-script gexps)
"Return the system's activation script, which evaluates 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)))
(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"))

;; Tell the kernel to use our 'modprobe' command.
(activate-modprobe #$modprobe)

;; 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
;; The activation service produces the activation script from the gexps it
;; receives.
(service activation-service-type #t))

(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 etc-service-type files))

(define setuid-program-service-type
(service-type (name 'setuid-program)
(extensions
(list (service-extension activation-service-type
(lambda (programs)
#~(activate-setuid-programs
(list #$@programs))))))
(compose concatenate)
(extend append)))

(define (firmware->activation-gexp firmware)
"Return a gexp to make the packages listed in FIRMWARE loadable by the
kernel."
(let ((directory (directory-union "firmware" firmware)))
;; Tell the kernel where firmware is.
#~(activate-firmware (string-append #$directory "/lib/firmware"))))

(define firmware-service-type
;; The service that collects firmware.
(service-type (name 'firmware)
(extensions
(list (service-extension activation-service-type
firmware->activation-gexp)))
(compose concatenate)
(extend append)))

;;;
;;; Service folding.
;;;

(define-condition-type &service-error &error
service-error?)

(define-condition-type &missing-target-service-error &service-error
missing-target-service-error?
(service missing-target-service-error-service)
(target-type missing-target-service-error-target-type))

(define-condition-type &ambiguous-target-service-error &service-error
ambiguous-target-service-error?
(service ambiguous-target-service-error-service)
(target-type ambiguous-target-service-error-target-type))

(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))
(()
(raise
(condition (&missing-target-service-error
(service service)
(target-type target-type))
(&message
(message
(format #f (_ "no target of type '~a' for service ~s")
(service-type-name target-type)
service))))))
(x
(raise
(condition (&ambiguous-target-service-error
(service service)
(target-type target-type))
(&message
(message
(format #f
(_ "more than one target service of type '~a'")
(service-type-name target-type))))))))))

(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
TARGET-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 (service-kind sink)
(extend params (compose extensions)))
sink))))
(()
(raise
(condition (&missing-target-service-error
(service #f)
(target-type target-type))
(&message
(message (format #f (_ "service of type '~a' not found")
(service-type-name target-type)))))))
(x
(raise
(condition (&ambiguous-target-service-error
(service #f)
(target-type target-type))
(&message
(message
(format #f
(_ "more than one target service of type '~a'")
(service-type-name target-type)))))))))

;;; services.scm ends here.

+ 82
- 40
gnu/services/avahi.scm View File

@@ -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,27 @@
;;;
;;; Code:

(define* (configuration-file #:key host-name publish?
ipv4? ipv6? wide-area? domains-to-browse)
"Return an avahi-daemon configuration file."
;; TODO: Export.
(define-record-type* <avahi-configuration>
avahi-configuration make-avahi-configuration
avahi-configuration?
(avahi avahi-configuration-avahi ;<package>
(default avahi))
(host-name avahi-configuration-host-name) ;string
(publish? avahi-configuration-publish?) ;Boolean
(ipv4? avahi-configuration-ipv4?) ;Boolean
(ipv6? avahi-configuration-ipv6?) ;Boolean
(wide-area? avahi-configuration-wide-area?) ;Boolean
(domains-to-browse avahi-configuration-domains-to-browse)) ;list of strings

(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 +63,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 +142,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 avahi-service-type
(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

+ 595
- 414
gnu/services/base.scm
File diff suppressed because it is too large
View File


+ 86
- 58
gnu/services/databases.scm View File

@@ -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,14 @@
;;;
;;; Code:

(define-record-type* <postgresql-configuration>
postgresql-configuration make-postgresql-configuration
postgresql-configuration?
(postgresql postgresql-configuration-postgresql ;<package>
(default postgresql))
(config-file postgresql-configuration-file)
(data-directory postgresql-configuration-data-directory))

(define %default-postgres-hba
(plain-file "pg_hba.conf"
"
@@ -49,6 +58,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)))))
(list (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 +136,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 postgresql-service-type
(postgresql-configuration
(postgresql postgresql)
(config-file config-file)
(data-directory data-directory))))

+ 178
- 0
gnu/services/dbus.scm View File

@@ -0,0 +1,178 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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-configuration make-dbus-configuration
dbus-configuration?
(dbus dbus-configuration-dbus ;<package>
(default dbus))
(services dbus-configuration-services ;list of <package>
(default '())))

(define (dbus-configuration-directory dbus services)
"Return a configuration directory for @var{dbus} that includes the
@code{etc/dbus-1/system.d} directories of each package listed in
@var{services}."
(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 #$@services))
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}.

@uref{http://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.

@var{services} must be a list of packages that provide an
@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
and policy files. For example, to allow avahi-daemon to use the system bus,
@var{services} must be equal to @code{(list avahi)}."
(service dbus-root-service-type
(dbus-configuration (dbus dbus)
(services services))))

;;; dbus.scm ends here

+ 354
- 291
gnu/services/desktop.scm View File

@@ -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,149 @@
(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
@code{etc/dbus-1/system.d} directories of each package listed in
@var{services}."
(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 #$@services))
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}.

@uref{http://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.

@var{services} must be a list of packages that provide an
@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
and policy files. For example, to allow avahi-daemon to use the system bus,
@var{services} 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-configuration make-upower-configuration
upower-configuration?
(upower upower-configuration-upower
(default upower))
(watts-up-pro? upower-configuration-watts-up-pro?)
(poll-batteries? upower-configuration-poll-batteries?)
(ignore-lid? upower-configuration-ignore-lid?)
(use-percentage-for-policy? upower-configuration-use-percentage-for-policy?)
(percentage-low upower-configuration-percentage-low)
(percentage-critical upower-configuration-percentage-critical)
(percentage-action upower-configuration-percentage-action)
(time-low upower-configuration-time-low)
(time-critical upower-configuration-time-critical)
(time-action upower-configuration-time-action)
(critical-power-action upower-configuration-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-dmd-service config)
"Return a dmd service for UPower with CONFIG."
(let ((upower (upower-configuration-upower config))
(config (upower-configuration-file config)))
(list (dmd-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))))))

(define upower-service-type
(service-type (name 'upower)
(extensions
(list (service-extension dbus-root-service-type
upower-dbus-service)
(service-extension dmd-root-service-type
upower-dmd-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 +224,97 @@ 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 upower-service-type 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-dmd-service colord)
"Return a dmd service for COLORD."
;; TODO: Remove when D-Bus activation works.
(list (dmd-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)))))

(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))
(service-extension dmd-root-service-type
colord-dmd-service)

;; 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 colord-service-type colord))

;;;
;;; GeoClue D-Bus service.
;;;

;; TODO: Export.
(define-record-type* <geoclue-configuration>
geoclue-configuration make-geoclue-configuration
geoclue-configuration?
(geoclue geoclue-configuration-geoclue
(default geoclue))
(whitelist geoclue-configuration-whitelist)
(wifi-geolocation-url geoclue-configuration-wifi-geolocation-url)
(submit-data? geoclue-configuration-submit-data?)
(wifi-submission-url geoclue-configuration-wifi-submission-url)
(submission-nick geoclue-configuration-submission-nick)
(applications geoclue-configuration-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 +334,67 @@ users are allowed."
(geoclue-application "epiphany" #:system? #f)
(geoclue-application "firefox" #:system? #f)))