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

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.
This commit is contained in:
Ludovic Courtès 2015-09-17 23:44:26 +02:00
parent e79467f63a
commit 0adfe95a3e
24 changed files with 3286 additions and 1647 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

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

1
Makefile.am
View File

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

3
doc.am
View File

@ -22,7 +22,8 @@ info_TEXINFOS = doc/guix.texi
DOT_FILES = \ DOT_FILES = \
doc/images/bootstrap-graph.dot \ doc/images/bootstrap-graph.dot \
doc/images/coreutils-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_VECTOR_GRAPHICS = \
$(DOT_FILES:%.dot=%.eps) \ $(DOT_FILES:%.dot=%.eps) \

467
doc/guix.texi
View File

@ -182,6 +182,13 @@ Services
* Web Services:: Web servers. * Web Services:: Web servers.
* Various Services:: Other services. * 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 Packaging Guidelines
* Software Freedom:: What may go into the distribution. * Software Freedom:: What may go into the distribution.
@ -5899,23 +5906,41 @@ Return a service that runs @code{syslogd}. If configuration file name
settings. settings.
@end deffn @end deffn
@deffn {Scheme Procedure} guix-service [#:guix guix] @ @anchor{guix-configuration-type}
[#:builder-group "guixbuild"] [#:build-accounts 10] @ @deftp {Data Type} guix-configuration
[#:authorize-hydra-key? #t] [#:use-substitutes? #t] @ This data type represents the configuration of the Guix build daemon.
[#:extra-options '()] @xref{Invoking guix-daemon}, for more information.
Return a service that runs the build daemon from @var{guix}, and has
@var{build-accounts} user accounts available under @var{builder-group}.
When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key @table @asis
provided by @var{guix} is authorized upon activation, meaning that substitutes @item @code{guix} (default: @var{guix})
from @code{hydra.gnu.org} are used by default. The Guix package to use.
If @var{use-substitutes?} is false, the daemon is run with @item @code{build-group} (default: @code{"guixbuild"})
@option{--no-substitutes} (@pxref{Invoking guix-daemon, Name of the group for build user accounts.
@option{--no-substitutes}}).
Finally, @var{extra-options} is a list of additional command-line options @item @code{build-accounts} (default: @code{10})
passed to @command{guix-daemon}. Number of build user accounts to create.
@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 @end deffn
@deffn {Scheme Procedure} udev-service [#:udev udev] @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 field of an @code{operating-system} declaration (@pxref{operating-system
Reference, @code{services}}). Reference, @code{services}}).
The actual service definitions provided by @code{(gnu services desktop)} The actual service definitions provided by @code{(gnu services dbus)}
are described below. and @code{(gnu services desktop)} are described below.
@deffn {Scheme Procedure} dbus-service @var{services} @ @deffn {Scheme Procedure} dbus-service [#:dbus @var{dbus}] [#:services '()]
[#:dbus @var{dbus}]
Return a service that runs the ``system bus'', using @var{dbus}, with Return a service that runs the ``system bus'', using @var{dbus}, with
support for @var{services}. 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)}. @var{services} must be equal to @code{(list avahi)}.
@end deffn @end deffn
@deffn {Scheme Procedure} elogind-service @ @deffn {Scheme Procedure} elogind-service [#:config @var{config}]
[#:elogind @var{elogind}] [#:config @var{config}]
Return a service that runs the @code{elogind} login and Return a service that runs the @code{elogind} login and
seat management daemon. @uref{https://github.com/andywingo/elogind, seat management daemon. @uref{https://github.com/andywingo/elogind,
Elogind} exposes a D-Bus interface that can be used to know which users Elogind} exposes a D-Bus interface that can be used to know which users
@ -6957,54 +6980,378 @@ build users.
@node Defining Services @node Defining Services
@subsection Defining Services @subsection Defining Services
The @code{(gnu services @dots{})} modules define several procedures that allow The previous sections how the available services and how one can combine
users to declare the operating system's services (@pxref{Using the them in an @code{operating-system} declaration. But how do we define
Configuration System}). These procedures are @emph{monadic them in the first place? And what is a service anyway?
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 @menu
The monadic value returned by those procedures is a @dfn{service * Service Composition:: The model for composing services.
definition}---a structure as returned by the @code{service} form. * Service Types and Services:: Types and services.
Service definitions specifies the inputs the service depends on, and an * Service Reference:: API reference.
expression to start and stop the service. Behind the scenes, service * dmd Services:: A particular type of service.
definitions are ``translated'' into the form suitable for the @end menu
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 @node Service Composition
like: @subsubsection Service Composition
@lisp @cindex services
(define (nscd-service) @cindex daemons
(with-monad %store-monad Here we define a @dfn{service} as, broadly, something that extends the
(return (service operating system's functionality. Often a service is a process---a
(documentation "Run libc's name service cache daemon.") @dfn{daemon}---started when the system boots: a secure shell server, a
(provision '(nscd)) Web server, the Guix build daemon, etc. Sometimes a service is a daemon
(activate #~(begin whose execution can be triggered by another daemon---e.g., an FTP server
(use-modules (guix build utils)) started by @command{inetd} or a D-Bus service activated by
(mkdir-p "/var/run/nscd"))) @command{dbus-daemon}. Occasionally, a service does not map to a
(start #~(make-forkexec-constructor daemon. For instance, the ``account'' service collects user accounts
(string-append #$glibc "/sbin/nscd") and makes sure they exist when the system runs; the ``udev'' service
"-f" "/dev/null" "--foreground")) collects device management rules and makes them available to the eudev
(stop #~(make-kill-destructor)) daemon; the @file{/etc} service populates the system's @file{/etc}
(respawn? #f))))) directory.
@end lisp
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 @noindent
The @code{activate}, @code{start}, and @code{stop} fields are G-expressions It defines a two things:
(@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.
@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 The @code{start} and @code{stop} fields refer to dmd's facilities to
start and stop processes (@pxref{Service De- and Constructors,,, dmd, start and stop processes (@pxref{Service De- and Constructors,,, dmd,
GNU dmd Manual}). The @code{provision} field specifies the name under GNU dmd Manual}). They are given as G-expressions that get expanded in
which this service is known to dmd, and @code{documentation} specifies the dmd configuration file (@pxref{G-Expressions}).
on-line documentation. Thus, the commands @command{deco start ncsd},
@command{deco stop nscd}, and @command{deco doc nscd} will do what you @item @code{documentation}
would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}). 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 @node Installing Debugging Files

35
doc/images/service-graph.dot Normal file
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
gnu-system.am
View File

@ -348,6 +348,7 @@ GNU_SYSTEM_MODULES = \
gnu/services/avahi.scm \ gnu/services/avahi.scm \
gnu/services/base.scm \ gnu/services/base.scm \
gnu/services/databases.scm \ gnu/services/databases.scm \
gnu/services/dbus.scm \
gnu/services/desktop.scm \ gnu/services/desktop.scm \
gnu/services/dmd.scm \ gnu/services/dmd.scm \
gnu/services/lirc.scm \ gnu/services/lirc.scm \

455
gnu/services.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,49 +18,428 @@
(define-module (gnu services) (define-module (gnu services)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix records) #:use-module (guix records)
#:export (service? #:use-module (guix sets)
service #:use-module (guix ui)
service-documentation #:use-module (gnu packages base)
service-provision #:use-module (gnu packages bash)
service-requirement #:use-module (srfi srfi-1)
service-respawn? #:use-module (srfi srfi-9)
service-start #:use-module (srfi srfi-9 gnu)
service-stop #:use-module (srfi srfi-26)
service-auto-start? #:use-module (srfi srfi-34)
service-activate #:use-module (srfi srfi-35)
service-user-accounts #:use-module (ice-9 vlist)
service-user-groups #:use-module (ice-9 match)
service-pam-services)) #:export (service-extension
service-extension?
;;; Commentary: service-type
service-type?
service
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:
;;; ;;;
;;; System services as cajoled by dmd. ;;; This module defines a broad notion of "service types" and "services."
;;;
;;; 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: ;;; Code:
(define-record-type* <service> (define-record-type <service-extension>
service make-service (service-extension target compute)
service? service-extension?
(documentation service-documentation ; string (target service-extension-target) ;<service-type>
(default "[No documentation.]")) (compute service-extension-compute)) ;params -> params
(provision service-provision) ; list of symbols
(requirement service-requirement ; list of symbols (define-record-type* <service-type> service-type make-service-type
(default '())) service-type?
(respawn? service-respawn? ; Boolean (name service-type-name) ;symbol (for debugging)
(default #t))
(start service-start) ; g-expression (procedure) ;; Things extended by services of this type.
(stop service-stop ; g-expression (procedure) (extensions service-type-extensions) ;list of <service-extensions>
(default #~(const #f)))
(auto-start? service-auto-start? ; Boolean ;; Given a list of extensions, "compose" them.
(default #t)) (compose service-type-compose ;list of Any -> Any
(user-accounts service-user-accounts ; list of <user-account> (default #f))
(default '()))
(user-groups service-user-groups ; list of <user-groups> ;; Extend the services' own parameters with the extension composition.
(default '())) (extend service-type-extend ;list of Any -> parameters
(pam-services service-pam-services ; list of <pam-service>
(default '()))
(activate service-activate ; gexp
(default #f))) (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?
(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. ;;; services.scm ends here.

122
gnu/services/avahi.scm
View File

@ -18,10 +18,13 @@
(define-module (gnu services avahi) (define-module (gnu services avahi)
#:use-module (gnu services) #: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 system shadow)
#:use-module (gnu packages avahi) #:use-module (gnu packages avahi)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (guix store) #:use-module (guix records)
#:use-module (guix gexp) #:use-module (guix gexp)
#:export (avahi-service)) #:export (avahi-service))
@ -32,12 +35,27 @@
;;; ;;;
;;; Code: ;;; Code:
(define* (configuration-file #:key host-name publish? ;; TODO: Export.
ipv4? ipv6? wide-area? domains-to-browse) (define-record-type* <avahi-configuration>
"Return an avahi-daemon configuration file." 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) (define (bool value)
(if value "yes\n" "no\n")) (if value "yes\n" "no\n"))
(define host-name (avahi-configuration-host-name config))
(plain-file "avahi-daemon.conf" (plain-file "avahi-daemon.conf"
(string-append (string-append
"[server]\n" "[server]\n"
@ -45,14 +63,63 @@
(string-append "host-name=" host-name "\n") (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" "\n"
"use-ipv4=" (bool ipv4?) "use-ipv4=" (bool (avahi-configuration-ipv4? config))
"use-ipv6=" (bool ipv6?) "use-ipv6=" (bool (avahi-configuration-ipv6? config))
"[wide-area]\n" "[wide-area]\n"
"enable-wide-area=" (bool wide-area?) "enable-wide-area=" (bool (avahi-configuration-wide-area? config))
"[publish]\n" "[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) (define* (avahi-service #:key (avahi avahi)
host-name 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 Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6
sockets." sockets."
(let ((config (configuration-file #:host-name host-name (service avahi-service-type
#:publish? publish? (avahi-configuration
#:ipv4? ipv4? (avahi avahi) (host-name host-name)
#:ipv6? ipv6? (publish? publish?) (ipv4? ipv4?) (ipv6? ipv6?)
#:wide-area? wide-area? (wide-area? wide-area?)
#:domains-to-browse (domains-to-browse 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"))))))))
;;; avahi.scm ends here ;;; avahi.scm ends here

513
gnu/services/base.scm
View File

@ -21,9 +21,11 @@
(define-module (gnu services base) (define-module (gnu services base)
#:use-module (guix store) #:use-module (guix store)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (gnu system shadow) ; 'user-account', etc. #:use-module (gnu system shadow) ; 'user-account', etc.
#:use-module (gnu system linux) ; 'pam-service', etc. #:use-module (gnu system linux) ; 'pam-service', etc.
#:use-module (gnu system file-systems) ; 'file-system', etc.
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module ((gnu packages linux) #:use-module ((gnu packages linux)
#:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda)) #:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda))
@ -49,6 +51,7 @@
host-name-service host-name-service
console-keymap-service console-keymap-service
console-font-service console-font-service
udev-service-type
udev-service udev-service
mingetty-configuration mingetty-configuration
@ -64,9 +67,14 @@
nscd-cache nscd-cache
nscd-cache? nscd-cache?
nscd-service-type
nscd-service nscd-service
syslog-service syslog-service
guix-configuration
guix-configuration?
guix-service guix-service
%base-services)) %base-services))
;;; Commentary: ;;; Commentary:
@ -76,13 +84,13 @@
;;; ;;;
;;; Code: ;;; Code:
(define (root-file-system-service)
"Return a service whose sole purpose is to re-mount read-only the root file ;;;
system upon shutdown (aka. cleanly \"umounting\" root.) ;;; File systems.
;;;
This service must be the root of the service dependency graph so that its (define %root-file-system-dmd-service
'stop' action is invoked when dmd is the only process left." (dmd-service
(service
(documentation "Take care of the root file system.") (documentation "Take care of the root file system.")
(provision '(root-file-system)) (provision '(root-file-system))
(start #~(const #t)) (start #~(const #t))
@ -116,26 +124,46 @@ This service must be the root of the service dependency graph so that its
#f))))) #f)))))
(respawn? #f))) (respawn? #f)))
(define* (file-system-service device target type (define root-file-system-service-type
#:key (flags '()) (check? #t) (dmd-service-type (const %root-file-system-dmd-service)))
create-mount-point? options (title 'any)
(requirements '())) (define (root-file-system-service)
"Return a service that mounts DEVICE on TARGET as a file system TYPE with "Return a service whose sole purpose is to re-mount read-only the root file
OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for system upon shutdown (aka. cleanly \"umounting\" root.)
a partition label, 'device for a device file name, or 'any. When CHECK? is
true, check the file system before mounting it. When CREATE-MOUNT-POINT? is This service must be the root of the service dependency graph so that its
true, create TARGET if it does not exist yet. FLAGS is a list of symbols, 'stop' action is invoked when dmd is the only process left."
such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service (service root-file-system-service-type #f))
names such as device-mapping services."
(service (define (file-system->dmd-service-name file-system)
(provision (list (symbol-append 'file-system- (string->symbol target)))) "Return the symbol that denotes the service mounting and unmounting
(requirement `(root-file-system ,@requirements)) FILE-SYSTEM."
(symbol-append 'file-system-
(string->symbol (file-system-mount-point file-system))))
(define file-system-service-type
;; TODO(?): Make this an extensible service that takes <file-system> objects
;; and returns a list of <dmd-service>.
(dmd-service-type
(lambda (file-system)
(let ((target (file-system-mount-point file-system))
(device (file-system-device file-system))
(type (file-system-type file-system))
(title (file-system-title file-system))
(check? (file-system-check? file-system))
(create? (file-system-create-mount-point? file-system))
(dependencies (file-system-dependencies file-system)))
(dmd-service
(provision (list (file-system->dmd-service-name file-system)))
(requirement `(root-file-system
,@(map file-system->dmd-service-name dependencies)))
(documentation "Check, mount, and unmount the given file system.") (documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args (start #~(lambda args
;; FIXME: Use or factorize with 'mount-file-system'. ;; FIXME: Use or factorize with 'mount-file-system'.
(let ((device (canonicalize-device-spec #$device '#$title)) (let ((device (canonicalize-device-spec #$device '#$title))
(flags #$(mount-flags->bit-mask flags))) (flags #$(mount-flags->bit-mask
#$(if create-mount-point? (file-system-flags file-system))))
#$(if create?
#~(mkdir-p #$target) #~(mkdir-p #$target)
#~#t) #~#t)
#$(if check? #$(if check?
@ -149,7 +177,8 @@ names such as device-mapping services."
(check-file-system device #$type)) (check-file-system device #$type))
#~#t) #~#t)
(mount device #$target #$type flags #$options) (mount device #$target #$type flags
#$(file-system-options file-system))
;; For read-only bind mounts, an extra remount is needed, ;; For read-only bind mounts, an extra remount is needed,
;; as per <http://lwn.net/Articles/281157/>, which still ;; as per <http://lwn.net/Articles/281157/>, which still
@ -167,20 +196,24 @@ names such as device-mapping services."
(chdir "/") (chdir "/")
(umount #$target) (umount #$target)
#f)))) #f)))))))
(define (user-unmount-service known-mount-points) (define* (file-system-service file-system)
"Return a service whose sole purpose is to unmount file systems not listed "Return a service that mounts @var{file-system}, a @code{<file-system>}
in KNOWN-MOUNT-POINTS when it is stopped." object."
(service (service file-system-service-type file-system))
(define user-unmount-service-type
(dmd-service-type
(lambda (known-mount-points)
(dmd-service
(documentation "Unmount manually-mounted file systems.") (documentation "Unmount manually-mounted file systems.")
(provision '(user-unmount)) (provision '(user-unmount))
(start #~(const #t)) (start #~(const #t))
(stop #~(lambda args (stop #~(lambda args
(define (known? mount-point) (define (known? mount-point)
(member mount-point (member mount-point
(cons* "/proc" "/sys" (cons* "/proc" "/sys" '#$known-mount-points)))
'#$known-mount-points)))
;; Make sure we don't keep the user's mount points busy. ;; Make sure we don't keep the user's mount points busy.
(chdir "/") (chdir "/")
@ -195,33 +228,33 @@ in KNOWN-MOUNT-POINTS when it is stopped."
(format #t "failed to unmount '~a': ~a~%" (format #t "failed to unmount '~a': ~a~%"
mount-point (strerror errno)))))) mount-point (strerror errno))))))
(filter (negate known?) (mount-points))) (filter (negate known?) (mount-points)))
#f)))) #f))))))
(define (user-unmount-service known-mount-points)
"Return a service whose sole purpose is to unmount file systems not listed
in KNOWN-MOUNT-POINTS when it is stopped."
(service user-unmount-service-type known-mount-points))
(define %do-not-kill-file (define %do-not-kill-file
;; Name of the file listing PIDs of processes that must survive when halting ;; Name of the file listing PIDs of processes that must survive when halting
;; the system. Typical example is user-space file systems. ;; the system. Typical example is user-space file systems.
"/etc/dmd/do-not-kill") "/etc/dmd/do-not-kill")
(define* (user-processes-service requirements #:key (grace-delay 4)) (define user-processes-service-type
"Return the service that is responsible for terminating all the processes so (dmd-service-type
that the root file system can be re-mounted read-only, just before (match-lambda
rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM ((requirements grace-delay)
has been sent are terminated with SIGKILL. (dmd-service
The returned service will depend on 'root-file-system' and on all the services
listed in REQUIREMENTS.
All the services that spawn processes must depend on this one so that they are
stopped before 'kill' is called."
(service
(documentation "When stopped, terminate all user processes.") (documentation "When stopped, terminate all user processes.")
(provision '(user-processes)) (provision '(user-processes))
(requirement (cons 'root-file-system requirements)) (requirement (cons 'root-file-system
(map file-system->dmd-service-name
requirements)))
(start #~(const #t)) (start #~(const #t))
(stop #~(lambda _ (stop #~(lambda _
(define (kill-except omit signal) (define (kill-except omit signal)
;; Kill all the processes with SIGNAL except those ;; Kill all the processes with SIGNAL except those listed
;; listed in OMIT and the current process. ;; in OMIT and the current process.
(let ((omit (cons (getpid) omit))) (let ((omit (cons (getpid) omit)))
(for-each (lambda (pid) (for-each (lambda (pid)
(unless (memv pid omit) (unless (memv pid omit)
@ -261,10 +294,10 @@ stopped before 'kill' is called."
(sleep* #$grace-delay) (sleep* #$grace-delay)
(kill -1 SIGKILL)) (kill -1 SIGKILL))
(begin (begin
;; Kill them all except OMITTED-PIDS. XXX: We ;; Kill them all except OMITTED-PIDS. XXX: We would
;; would like to (kill -1 SIGSTOP) to get a fixed ;; like to (kill -1 SIGSTOP) to get a fixed list of
;; list of processes, like 'killall5' does, but ;; processes, like 'killall5' does, but that seems
;; that seems unreliable. ;; unreliable.
(kill-except omitted-pids SIGTERM) (kill-except omitted-pids SIGTERM)
(sleep* #$grace-delay) (sleep* #$grace-delay)
(kill-except omitted-pids SIGKILL) (kill-except omitted-pids SIGKILL)
@ -281,16 +314,40 @@ stopped before 'kill' is called."
(display "all processes have been terminated\n") (display "all processes have been terminated\n")
#f)) #f))
(respawn? #f))) (respawn? #f))))))
(define (host-name-service name) (define* (user-processes-service file-systems #:key (grace-delay 4))
"Return a service that sets the host name to @var{name}." "Return the service that is responsible for terminating all the processes so
(service that the root file system can be re-mounted read-only, just before
rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
has been sent are terminated with SIGKILL.
The returned service will depend on 'root-file-system' and on all the dmd
services corresponding to FILE-SYSTEMS.
All the services that spawn processes must depend on this one so that they are
stopped before 'kill' is called."
(service user-processes-service-type
(list file-systems grace-delay)))
;;;
;;; Console & co.
;;;
(define host-name-service-type
(dmd-service-type
(lambda (name)
(dmd-service
(documentation "Initialize the machine's host name.") (documentation "Initialize the machine's host name.")
(provision '(host-name)) (provision '(host-name))
(start #~(lambda _ (start #~(lambda _
(sethostname #$name))) (sethostname #$name)))
(respawn? #f))) (respawn? #f)))))
(define (host-name-service name)
"Return a service that sets the host name to @var{name}."
(service host-name-service-type name))
(define (unicode-start tty) (define (unicode-start tty)
"Return a gexp to start Unicode support on @var{tty}." "Return a gexp to start Unicode support on @var{tty}."
@ -310,30 +367,33 @@ stopped before 'kill' is called."
(else (else
(zero? (cdr (waitpid pid)))))))) (zero? (cdr (waitpid pid))))))))
(define (console-keymap-service file) (define console-keymap-service-type
"Return a service to load console keymap from @var{file}." (dmd-service-type
(service (lambda (file)
(dmd-service
(documentation (string-append "Load console keymap (loadkeys).")) (documentation (string-append "Load console keymap (loadkeys)."))
(provision '(console-keymap)) (provision '(console-keymap))
(start #~(lambda _ (start #~(lambda _
(zero? (system* (string-append #$kbd "/bin/loadkeys") (zero? (system* (string-append #$kbd "/bin/loadkeys")
#$file)))) #$file))))
(respawn? #f))) (respawn? #f)))))
(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16")) (define (console-keymap-service file)
"Return a service that sets up Unicode support in @var{tty} and loads "Return a service to load console keymap from @var{file}."
@var{font} for that tty (fonts are per virtual console in Linux.)" (service console-keymap-service-type file))
;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
;; scripts as well as glyphs for em dash, quotation marks, and other Unicode (define console-font-service-type
;; codepoints notably found in the UTF-8 manual. (dmd-service-type
(match-lambda
((tty font)
(let ((device (string-append "/dev/" tty))) (let ((device (string-append "/dev/" tty)))
(service (dmd-service
(documentation "Load a Unicode console font.") (documentation "Load a Unicode console font.")
(provision (list (symbol-append 'console-font- (provision (list (symbol-append 'console-font-
(string->symbol tty)))) (string->symbol tty))))
;; Start after mingetty has been started on TTY, otherwise the ;; Start after mingetty has been started on TTY, otherwise the settings
;; settings are ignored. ;; are ignored.
(requirement (list (symbol-append 'term- (requirement (list (symbol-append 'term-
(string->symbol tty)))) (string->symbol tty))))
@ -343,7 +403,15 @@ stopped before 'kill' is called."
(system* (string-append #$kbd "/bin/setfont") (system* (string-append #$kbd "/bin/setfont")
"-C" #$device #$font))))) "-C" #$device #$font)))))
(stop #~(const #t)) (stop #~(const #t))
(respawn? #f)))) (respawn? #f)))))))
(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
"Return a service that sets up Unicode support in @var{tty} and loads
@var{font} for that tty (fonts are per virtual console in Linux.)"
;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
;; codepoints notably found in the UTF-8 manual.
(service console-font-service-type (list tty font)))
(define-record-type* <mingetty-configuration> (define-record-type* <mingetty-configuration>
mingetty-configuration make-mingetty-configuration mingetty-configuration make-mingetty-configuration
@ -365,14 +433,23 @@ stopped before 'kill' is called."
(allow-empty-passwords? mingetty-configuration-allow-empty-passwords? (allow-empty-passwords? mingetty-configuration-allow-empty-passwords?
(default #t))) ;Boolean (default #t))) ;Boolean
(define* (mingetty-service config) (define (mingetty-pam-service conf)
"Return a service to run mingetty according to @var{config}, a "Return the list of PAM service needed for CONF."
@code{<mingetty-configuration>} object, which specifies the tty to run, among ;; Let 'login' be known to PAM. All the mingetty services will have that
other things." ;; PAM service, but that's fine because they're all identical and duplicates
(match config ;; are removed.
(list (unix-pam-service "login"
#:allow-empty-passwords?
(mingetty-configuration-allow-empty-passwords? conf)
#:motd
(mingetty-configuration-motd conf))))
(define mingetty-dmd-service
(match-lambda
(($ <mingetty-configuration> mingetty tty motd auto-login login-program (($ <mingetty-configuration> mingetty tty motd auto-login login-program
login-pause? allow-empty-passwords?) login-pause? allow-empty-passwords?)
(service (list
(dmd-service
(documentation "Run mingetty on an tty.") (documentation "Run mingetty on an tty.")
(provision (list (symbol-append 'term- (string->symbol tty)))) (provision (list (symbol-append 'term- (string->symbol tty))))
@ -393,15 +470,19 @@ other things."
#$@(if login-pause? #$@(if login-pause?
#~("--loginpause") #~("--loginpause")
#~())))) #~()))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor)))))))
(pam-services (define mingetty-service-type
;; Let 'login' be known to PAM. All the mingetty services will have (service-type (name 'mingetty)
;; that PAM service, but that's fine because they're all identical and (extensions (list (service-extension dmd-root-service-type
;; duplicates are removed. mingetty-dmd-service)
(list (unix-pam-service "login" (service-extension pam-root-service-type
#:allow-empty-passwords? allow-empty-passwords? mingetty-pam-service)))))
#:motd motd)))))))
(define* (mingetty-service config)
"Return a service to run mingetty according to @var{config}, which specifies
the tty to run, among other things."
(service mingetty-service-type config))
(define-record-type* <nscd-configuration> nscd-configuration (define-record-type* <nscd-configuration> nscd-configuration
make-nscd-configuration make-nscd-configuration
@ -506,21 +587,14 @@ other things."
(string-concatenate (string-concatenate
(map cache->config caches))))))) (map cache->config caches)))))))
(define* (nscd-service #:optional (config %nscd-default-configuration)) (define (nscd-dmd-service config)
"Return a service that runs libc's name service cache daemon (nscd) with the "Return a dmd service for CONFIG, an <nscd-configuration> object."
given @var{config}---an @code{<nscd-configuration>} object. @xref{Name (let ((nscd.conf (nscd.conf-file config))
Service Switch}, for an example." (name-services (nscd-configuration-name-services config)))
(let ((nscd.conf (nscd.conf-file config))) (list (dmd-service
(service
(documentation "Run libc's name service cache daemon (nscd).") (documentation "Run libc's name service cache daemon (nscd).")
(provision '(nscd)) (provision '(nscd))
(requirement '(user-processes)) (requirement '(user-processes))
(activate #~(begin
(use-modules (guix build utils))
(mkdir-p "/var/run/nscd")
(mkdir-p "/var/db/nscd"))) ;for the persistent cache
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$(nscd-configuration-glibc config) (list (string-append #$(nscd-configuration-glibc config)
"/sbin/nscd") "/sbin/nscd")
@ -531,13 +605,54 @@ Service Switch}, for an example."
(string-join (string-join
(map (lambda (dir) (map (lambda (dir)
(string-append dir "/lib")) (string-append dir "/lib"))
(list (list #$@name-services))
#$@(nscd-configuration-name-services
config)))
":"))))) ":")))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(respawn? #f)))) (respawn? #f)))))
(define nscd-activation
;; Actions to take before starting nscd.
#~(begin
(use-modules (guix build utils))
(mkdir-p "/var/run/nscd")
(mkdir-p "/var/db/nscd"))) ;for the persistent cache
(define nscd-service-type
(service-type (name 'nscd)
(extensions
(list (service-extension activation-service-type
(const nscd-activation))
(service-extension dmd-root-service-type
nscd-dmd-service)))
;; This can be extended by providing additional name services
;; such as nss-mdns.
(compose concatenate)
(extend (lambda (config name-services)
(nscd-configuration
(inherit config)
(name-services (append
(nscd-configuration-name-services config)
name-services)))))))
(define* (nscd-service #:optional (config %nscd-default-configuration))
"Return a service that runs libc's name service cache daemon (nscd) with the
given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
Service Switch}, for an example."
(service nscd-service-type config))
(define syslog-service-type
(dmd-service-type
(lambda (config-file)
(dmd-service
(documentation "Run the syslog daemon (syslogd).")
(provision '(syslogd))
(requirement '(user-processes))
(start #~(make-forkexec-constructor
(list (string-append #$inetutils "/libexec/syslogd")
"--no-detach" "--rcfile" #$config-file)))
(stop #~(make-kill-destructor))))))
;; Snippet adapted from the GNU inetutils manual. ;; Snippet adapted from the GNU inetutils manual.
(define %default-syslog.conf (define %default-syslog.conf
@ -561,18 +676,12 @@ Service Switch}, for an example."
# Log all the mail messages in one place. # Log all the mail messages in one place.
mail.* /var/log/maillog mail.* /var/log/maillog
")) "))
(define* (syslog-service #:key (config-file %default-syslog.conf)) (define* (syslog-service #:key (config-file %default-syslog.conf))
"Return a service that runs @code{syslogd}. "Return a service that runs @code{syslogd}.
If configuration file name @var{config-file} is not specified, use some If configuration file name @var{config-file} is not specified, use some
reasonable default settings." reasonable default settings."
(service (service syslog-service-type config-file))
(documentation "Run the syslog daemon (syslogd).")
(provision '(syslogd))
(requirement '(user-processes))
(start #~(make-forkexec-constructor
(list (string-append #$inetutils "/libexec/syslogd")
"--no-detach" "--rcfile" #$config-file)))
(stop #~(make-kill-destructor))))
(define* (guix-build-accounts count #:key (define* (guix-build-accounts count #:key
(group "guixbuild") (group "guixbuild")
@ -621,41 +730,42 @@ GUIX."
(format (current-error-port) "warning: \ (format (current-error-port) "warning: \
failed to register hydra.gnu.org public key: ~a~%" status)))))))) failed to register hydra.gnu.org public key: ~a~%" status))))))))
(define* (guix-service #:key (guix guix) (builder-group "guixbuild") (define-record-type* <guix-configuration>
(build-accounts 10) (authorize-hydra-key? #t) guix-configuration make-guix-configuration
(use-substitutes? #t) guix-configuration?
(extra-options '()) (guix guix-configuration-guix ;<package>
(lsof lsof) (lsh lsh)) (default guix))
"Return a service that runs the build daemon from @var{guix}, and has (build-group guix-configuration-build-group ;string
@var{build-accounts} user accounts available under @var{builder-group}. (default "guixbuild"))
(build-accounts guix-configuration-build-accounts ;integer
(default 10))
(authorize-key? guix-configuration-authorize-key? ;Boolean
(default #t))
(use-substitutes? guix-configuration-use-substitutes? ;Boolean
(default #t))
(extra-options guix-configuration-extra-options ;list of strings
(default '()))
(lsof guix-configuration-lsof ;<package>
(default lsof))
(lsh guix-configuration-lsh ;<package>
(default lsh)))
When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key (define %default-guix-configuration
provided by @var{guix} is authorized upon activation, meaning that substitutes (guix-configuration))
from @code{hydra.gnu.org} are used by default.
If @var{use-substitutes?} is false, the daemon is run with (define (guix-dmd-service config)
@option{--no-substitutes} (@pxref{Invoking guix-daemon, "Return a <dmd-service> for the Guix daemon service with CONFIG."
@option{--no-substitutes}}). (match config
(($ <guix-configuration> guix build-group build-accounts authorize-key?
Finally, @var{extra-options} is a list of additional command-line options use-substitutes? extra-options lsof lsh)
passed to @command{guix-daemon}." (list (dmd-service
(define activate
;; Assume that the store has BUILDER-GROUP as its group. We could
;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
;; chown leads to an entire copy of the tree, which is a bad idea.
;; Optionally authorize hydra.gnu.org's key.
(and authorize-hydra-key?
(hydra-key-authorization guix)))
(service
(documentation "Run the Guix daemon.") (documentation "Run the Guix daemon.")
(provision '(guix-daemon)) (provision '(guix-daemon))
(requirement '(user-processes)) (requirement '(user-processes))
(start (start
#~(make-forkexec-constructor #~(make-forkexec-constructor
(list (string-append #$guix "/bin/guix-daemon") (list (string-append #$guix "/bin/guix-daemon")
"--build-users-group" #$builder-group "--build-users-group" #$build-group
#$@(if use-substitutes? #$@(if use-substitutes?
'() '()
'("--no-substitutes")) '("--no-substitutes"))
@ -665,17 +775,59 @@ passed to @command{guix-daemon}."
;; daemon's $PATH. ;; daemon's $PATH.
#:environment-variables #:environment-variables
(list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin")))) (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor)))))))
(user-accounts (guix-build-accounts build-accounts
#:group builder-group)) (define (guix-accounts config)
(user-groups (list (user-group "Return the user accounts and user groups for CONFIG."
(name builder-group) (match config
(($ <guix-configuration> _ build-group build-accounts)
(cons (user-group
(name build-group)
(system? #t) (system? #t)
;; Use a fixed GID so that we can create the ;; Use a fixed GID so that we can create the store with the right
;; store with the right owner. ;; owner.
(id 30000)))) (id 30000))
(activate activate))) (guix-build-accounts build-accounts
#:group build-group)))))
(define (guix-activation config)
"Return the activation gexp for CONFIG."
(match config
(($ <guix-configuration> guix build-group build-accounts authorize-key?)
;; Assume that the store has BUILD-GROUP as its group. We could
;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
;; chown leads to an entire copy of the tree, which is a bad idea.
;; Optionally authorize hydra.gnu.org's key.
(and authorize-key?
(hydra-key-authorization guix)))))
(define guix-service-type
(service-type
(name 'guix)
(extensions
(list (service-extension dmd-root-service-type guix-dmd-service)
(service-extension account-service-type guix-accounts)
(service-extension activation-service-type guix-activation)))))
(define* (guix-service #:optional (config %default-guix-configuration))
"Return a service that runs the Guix build daemon according to
@var{config}."
(service guix-service-type config))
;;;
;;; Udev.
;;;
(define-record-type* <udev-configuration>
udev-configuration make-udev-configuration
udev-configuration?
(udev udev-configuration-udev ;<package>
(default udev))
(rules udev-configuration-rules ;list of <package>
(default '())))
(define (udev-rules-union packages) (define (udev-rules-union packages)
"Return the union of the @code{lib/udev/rules.d} directories found in each "Return the union of the @code{lib/udev/rules.d} directories found in each
@ -727,19 +879,19 @@ item of @var{packages}."
KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port)))) KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port))))
#:modules '((guix build utils)))) #:modules '((guix build utils))))
(define* (udev-service #:key (udev eudev) (rules '())) (define udev-dmd-service
"Run @var{udev}, which populates the @file{/dev} directory dynamically. Get ;; Return a <dmd-service> for UDEV with RULES.
extra rules from the packages listed in @var{rules}." (match-lambda
(let* ((rules (udev-rules-union (cons* udev (($ <udev-configuration> udev rules)
(kvm-udev-rule) (let* ((rules (udev-rules-union (cons* udev (kvm-udev-rule) rules)))
rules)))
(udev.conf (computed-file "udev.conf" (udev.conf (computed-file "udev.conf"
#~(call-with-output-file #$output #~(call-with-output-file #$output
(lambda (port) (lambda (port)
(format port (format port
"udev_rules=\"~a/lib/udev/rules.d\"\n" "udev_rules=\"~a/lib/udev/rules.d\"\n"
#$rules)))))) #$rules))))))
(service (list
(dmd-service
(provision '(udev)) (provision '(udev))
;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
@ -804,31 +956,59 @@ extra rules from the packages listed in @var{rules}."
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
;; When halting the system, 'udev' is actually killed by ;; When halting the system, 'udev' is actually killed by
;; 'user-processes', i.e., before its own 'stop' method was ;; 'user-processes', i.e., before its own 'stop' method was called.
;; called. Thus, make sure it is not respawned. ;; Thus, make sure it is not respawned.
(respawn? #f)))) (respawn? #f)))))))
(define (device-mapping-service target open close) (define udev-service-type
"Return a service that maps device @var{target}, a string such as (service-type (name 'udev)
@code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a (extensions
gexp, to open it, and evaluate @var{close} to close it." (list (service-extension dmd-root-service-type
(service udev-dmd-service)))
(compose concatenate) ;concatenate the list of rules
(extend (lambda (config rules)
(match config
(($ <udev-configuration> udev initial-rules)
(udev-configuration
(udev udev)
(rules (append initial-rules rules)))))))))
(define* (udev-service #:key (udev eudev) (rules '()))
"Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
extra rules from the packages listed in @var{rules}."
(service udev-service-type
(udev-configuration (udev udev) (rules rules))))
(define device-mapping-service-type
(dmd-service-type
(match-lambda
((target open close)
(dmd-service
(provision (list (symbol-append 'device-mapping- (string->symbol target)))) (provision (list (symbol-append 'device-mapping- (string->symbol target))))
(requirement '(udev)) (requirement '(udev))
(documentation "Map a device node using Linux's device mapper.") (documentation "Map a device node using Linux's device mapper.")
(start #~(lambda () #$open)) (start #~(lambda () #$open))
(stop #~(lambda _ (not #$close))) (stop #~(lambda _ (not #$close)))
(respawn? #f))) (respawn? #f))))))
(define (swap-service device) (define (device-mapping-service target open close)
"Return a service that uses @var{device} as a swap device." "Return a service that maps device @var{target}, a string such as
@code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a
gexp, to open it, and evaluate @var{close} to close it."
(service device-mapping-service-type
(list target open close)))
(define swap-service-type
(dmd-service-type
(lambda (device)
(define requirement (define requirement
(if (string-prefix? "/dev/mapper/" device) (if (string-prefix? "/dev/mapper/" device)
(list (symbol-append 'device-mapping- (list (symbol-append 'device-mapping-
(string->symbol (basename device)))) (string->symbol (basename device))))
'())) '()))
(service (dmd-service
(provision (list (symbol-append 'swap- (string->symbol device)))) (provision (list (symbol-append 'swap- (string->symbol device))))
(requirement `(udev ,@requirement)) (requirement `(udev ,@requirement))
(documentation "Enable the given swap device.") (documentation "Enable the given swap device.")
@ -838,7 +1018,11 @@ gexp, to open it, and evaluate @var{close} to close it."
(stop #~(lambda _ (stop #~(lambda _
(restart-on-EINTR (swapoff #$device)) (restart-on-EINTR (swapoff #$device))
#f)) #f))
(respawn? #f))) (respawn? #f)))))
(define (swap-service device)
"Return a service that uses @var{device} as a swap device."
(service swap-service-type device))
(define %base-services (define %base-services
;; Convenience variable holding the basic services. ;; Convenience variable holding the basic services.
@ -873,9 +1057,6 @@ This is the GNU operating system, welcome!\n\n")))
;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
;; used, so enable them by default. The FUSE and ALSA rules are ;; used, so enable them by default. The FUSE and ALSA rules are
;; less critical, but handy. ;; less critical, but handy.
;;
;; XXX Keep this in sync with the 'udev-service' call in
;; %desktop-services.
(udev-service #:rules (list lvm2 fuse alsa-utils crda))))) (udev-service #:rules (list lvm2 fuse alsa-utils crda)))))
;;; base.scm ends here ;;; base.scm ends here

100
gnu/services/databases.scm
View File

@ -19,12 +19,13 @@
(define-module (gnu services databases) (define-module (gnu services databases)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages databases) #:use-module (gnu packages databases)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (ice-9 match)
#:export (postgresql-service)) #:export (postgresql-service))
;;; Commentary: ;;; Commentary:
@ -33,6 +34,14 @@
;;; ;;;
;;; Code: ;;; 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 (define %default-postgres-hba
(plain-file "pg_hba.conf" (plain-file "pg_hba.conf"
" "
@ -49,27 +58,19 @@ host all all ::1/128 trust"))
"hba_file = '" %default-postgres-hba "'\n" "hba_file = '" %default-postgres-hba "'\n"
"ident_file = '" %default-postgres-ident "\n")) "ident_file = '" %default-postgres-ident "\n"))
(define* (postgresql-service #:key (postgresql postgresql) (define %postgresql-accounts
(config-file %default-postgres-config) (list (user-group (name "postgres") (system? #t))
(data-directory "/var/lib/postgresql/data")) (user-account
"Return a service that runs @var{postgresql}, the PostgreSQL database server. (name "postgres")
(group "postgres")
(system? #t)
(comment "PostgreSQL server user")
(home-directory "/var/empty")
(shell #~(string-append #$shadow "/sbin/nologin")))))
The PostgreSQL daemon loads its runtime configuration from @var{config-file} (define postgresql-activation
and stores the database cluster in @var{data-directory}." (match-lambda
;; Wrapper script that switches to the 'postgres' user before launching (($ <postgresql-configuration> postgresql config-file data-directory)
;; 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 #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
(ice-9 match)) (ice-9 match))
@ -93,23 +94,50 @@ and stores the database cluster in @var{data-directory}."
(primitive-exit (system* initdb "-D" #$data-directory))) (primitive-exit (system* initdb "-D" #$data-directory)))
(lambda () (lambda ()
(primitive-exit 1)))) (primitive-exit 1))))
(pid (waitpid pid)))))) (pid (waitpid pid))))))))
(service (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)) (provision '(postgres))
(documentation "Run the PostgreSQL daemon.") (documentation "Run the PostgreSQL daemon.")
(requirement '(user-processes loopback)) (requirement '(user-processes loopback))
(start #~(make-forkexec-constructor #$start-script)) (start #~(make-forkexec-constructor #$start-script))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))))))))
(activate activate)
(user-groups (list (user-group (define postgresql-service-type
(name "postgres") (service-type (name 'postgresql)
(system? #t)))) (extensions
(user-accounts (list (user-account (list (service-extension dmd-root-service-type
(name "postgres") postgresql-dmd-service)
(group "postgres") (service-extension activation-service-type
(system? #t) postgresql-activation)
(comment "PostgreSQL server user") (service-extension account-service-type
(home-directory "/var/empty") (const %postgresql-accounts))))))
(shell
#~(string-append #$shadow "/sbin/nologin"))))))) (define* (postgresql-service #:key (postgresql postgresql)
(config-file %default-postgres-config)
(data-directory "/var/lib/postgresql/data"))
"Return a service that runs @var{postgresql}, the PostgreSQL database server.
The PostgreSQL daemon loads its runtime configuration from @var{config-file}
and stores the database cluster in @var{data-directory}."
(service postgresql-service-type
(postgresql-configuration
(postgresql postgresql)
(config-file config-file)
(data-directory data-directory))))

178
gnu/services/dbus.scm Normal file
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

593
gnu/services/desktop.scm
View File

@ -20,7 +20,9 @@
(define-module (gnu services desktop) (define-module (gnu services desktop)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd)
#:use-module (gnu services base) #:use-module (gnu services base)
#:use-module (gnu services dbus)
#:use-module (gnu services avahi) #:use-module (gnu services avahi)
#:use-module (gnu services xorg) #:use-module (gnu services xorg)
#:use-module (gnu services networking) #:use-module (gnu services networking)
@ -31,16 +33,14 @@
#:use-module (gnu packages freedesktop) #:use-module (gnu packages freedesktop)
#:use-module (gnu packages gnome) #:use-module (gnu packages gnome)
#:use-module (gnu packages avahi) #:use-module (gnu packages avahi)
#:use-module (gnu packages wicd)
#:use-module (gnu packages polkit) #:use-module (gnu packages polkit)
#:use-module ((gnu packages linux)
#:select (lvm2 fuse alsa-utils crda))
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (dbus-service #:export (upower-service
upower-service
colord-service colord-service
geoclue-application geoclue-application
%standard-geoclue-applications %standard-geoclue-applications
@ -64,115 +64,74 @@
(define (bool value) (define (bool value)
(if value "true\n" "false\n")) (if value "true\n" "false\n"))
;;;
;;; D-Bus.
;;;
(define (dbus-configuration-directory dbus services) (define (wrapped-dbus-service service program variable value)
"Return a configuration directory for @var{dbus} that includes the "Return a wrapper for @var{service}, a package containing a D-Bus service,
@code{etc/dbus-1/system.d} directories of each package listed in where @var{program} is wrapped such that environment variable @var{variable}
@var{services}." is set to @var{value} when the bus daemon launches it."
(define build (define wrapper
(program-file (string-append (package-name service) "-program-wrapper")
#~(begin #~(begin
(use-modules (sxml simple) (setenv #$variable #$value)
(srfi srfi-1)) (apply execl (string-append #$service "/" #$program)
(string-append #$service "/" #$program)
(cdr (command-line))))))
(define (services->sxml services) (computed-file (string-append (package-name service) "-wrapper")
;; Return the SXML 'includedir' clauses for DIRS. #~(begin
`(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)) (use-modules (guix build utils))
(mkdir-p "/var/run/dbus") (define service-directory
"/share/dbus-1/system-services")
(let ((user (getpwnam "messagebus"))) (mkdir-p (dirname (string-append #$output
(chown "/var/run/dbus" service-directory)))
(passwd:uid user) (passwd:gid user))) (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"))
(unless (file-exists? "/etc/machine-id") (for-each (lambda (file)
(format #t "creating /etc/machine-id...~%") (substitute* file
(let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
;; XXX: We can't use 'system' because the initrd's _ original-program arguments)
;; guile system(3) only works when 'sh' is in $PATH. (string-append "Exec=" #$wrapper arguments
(let ((pid (primitive-fork))) "\n"))))
(if (zero? pid) (find-files #$output "\\.service$")))
(call-with-output-file "/etc/machine-id" #:modules '((guix build utils))))
(lambda (port)
(close-fdes 1)
(dup2 (port->fdes port) 1)
(execl prog)))
(waitpid pid))))))))))
;;; ;;;
;;; Upower D-Bus service. ;;; Upower D-Bus service.
;;; ;;;
(define* (upower-configuration-file #:key watts-up-pro? poll-batteries? ;; TODO: Export.
ignore-lid? use-percentage-for-policy? (define-record-type* <upower-configuration>
percentage-low percentage-critical upower-configuration make-upower-configuration
percentage-action time-low upower-configuration?
time-critical time-action (upower upower-configuration-upower
critical-power-action) (default upower))
"Return an upower-daemon configuration file." (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" (plain-file "UPower.conf"
(string-append (string-append
"[UPower]\n" "[UPower]\n"
@ -190,7 +149,64 @@ and policy files. For example, to allow avahi-daemon to use the system bus,
('hybrid-sleep "HybridSleep") ('hybrid-sleep "HybridSleep")
('hibernate "Hibernate") ('hibernate "Hibernate")
('power-off "PowerOff")) ('power-off "PowerOff"))
"\n"))) "\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) (define* (upower-service #:key (upower upower)
(watts-up-pro? #f) (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 @command{upowerd}}, a system-wide monitor for power consumption and battery
levels, with the given configuration settings. It implements the levels, with the given configuration settings. It implements the
@code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME." @code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME."
(let ((config (upower-configuration-file (let ((config (upower-configuration
#:watts-up-pro? watts-up-pro? (watts-up-pro? watts-up-pro?)
#:poll-batteries? poll-batteries? (poll-batteries? poll-batteries?)
#:ignore-lid? ignore-lid? (ignore-lid? ignore-lid?)
#:use-percentage-for-policy? use-percentage-for-policy? (use-percentage-for-policy? use-percentage-for-policy?)
#:percentage-low percentage-low (percentage-low percentage-low)
#:percentage-critical percentage-critical (percentage-critical percentage-critical)
#:percentage-action percentage-action (percentage-action percentage-action)
#:time-low time-low (time-low time-low)
#:time-critical time-critical (time-critical time-critical)
#:time-action time-action (time-action time-action)
#:critical-power-action critical-power-action))) (critical-power-action critical-power-action))))
(service (service upower-service-type config)))
(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"))))))))
;;; ;;;
;;; Colord D-Bus service. ;;; 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)) (define* (colord-service #:key (colord colord))
"Return a service that runs @command{colord}, a system service with a D-Bus "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 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 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 tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web
site} for more information." site} for more information."
(service (service colord-service-type colord))
(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")))))))
;;; ;;;
;;; GeoClue D-Bus service. ;;; 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 '())) (define* (geoclue-application name #:key (allowed? #t) system? (users '()))
"Configure default GeoClue access permissions for an application. NAME is "Configure default GeoClue access permissions for an application. NAME is
the Desktop ID of the application, without the .desktop part. If ALLOWED? 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 "epiphany" #:system? #f)
(geoclue-application "firefox" #:system? #f))) (geoclue-application "firefox" #:system? #f)))
(define* (geoclue-configuration-file #:key whitelist wifi-geolocation-url (define* (geoclue-configuration-file config)
submit-data?
wifi-submission-url submission-nick
applications)
"Return a geoclue configuration file." "Return a geoclue configuration file."
(plain-file "geoclue.conf" (plain-file "geoclue.conf"
(string-append (string-append
"[agent]\n" "[agent]\n"
"whitelist=" (string-join whitelist ";") "\n" "whitelist="
(string-join (geoclue-configuration-whitelist config)
";") "\n"
"[wifi]\n" "[wifi]\n"
"url=" wifi-geolocation-url "\n" "url=" (geoclue-configuration-wifi-geolocation-url config) "\n"
"submit-data=" (bool submit-data?) "submit-data=" (bool (geoclue-configuration-submit-data? config))
"submission-url=" wifi-submission-url "\n" "submission-url="
"submission-nick=" submission-nick "\n" (geoclue-configuration-wifi-submission-url config) "\n"
(string-join applications "\n")))) "submission-nick="
(geoclue-configuration-submission-nick config)
"\n"
(string-join (geoclue-configuration-applications config)
"\n"))))
(define (geoclue-dbus-service config)
(list (wrapped-dbus-service (geoclue-configuration-geoclue config)
"libexec/geoclue"
"GEOCLUE_CONFIG_FILE"
(geoclue-configuration-file config))))
(define (geoclue-dmd-service config)
"Return a GeoClue dmd service for CONFIG."
;; TODO: Remove when D-Bus activation works.
(let ((geoclue (geoclue-configuration-geoclue config))
(config (geoclue-configuration-file config)))
(list (dmd-service
(documentation "Run the GeoClue location service.")
(provision '(geoclue-daemon))
(requirement '(dbus-system))
(start #~(make-forkexec-constructor
(list (string-append #$geoclue "/libexec/geoclue"))
#:user "geoclue"
#:environment-variables
(list (string-append "GEOCLUE_CONFIG_FILE=" #$config))))
(stop #~(make-kill-destructor))))))
(define %geoclue-accounts
(list (user-group (name "geoclue") (system? #t))
(user-account
(name "geoclue")
(group "geoclue")
(system? #t)
(comment "GeoClue daemon user")
(home-directory "/var/empty")
(shell "/run/current-system/profile/sbin/nologin"))))
(define geoclue-service-type
(service-type (name 'geoclue)
(extensions
(list (service-extension dbus-root-service-type
geoclue-dbus-service)
(service-extension dmd-root-service-type
geoclue-dmd-service)
(service-extension account-service-type
(const %geoclue-accounts))))))
(define* (geoclue-service #:key (geoclue geoclue) (define* (geoclue-service #:key (geoclue geoclue)
(whitelist '()) (whitelist '())
@ -345,70 +414,67 @@ and Epiphany web browsers are able to ask for the user's location, and in the
case of Icecat and Epiphany, both will ask the user for permission first. See case of Icecat and Epiphany, both will ask the user for permission first. See
@uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web @uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web
site} for more information." site} for more information."
(let ((config (geoclue-configuration-file (service geoclue-service-type
#:whitelist whitelist (geoclue-configuration
#:wifi-geolocation-url wifi-geolocation-url (geoclue geoclue)
#:submit-data? submit-data? (whitelist whitelist)
#:wifi-submission-url wifi-submission-url (wifi-geolocation-url wifi-geolocation-url)
#:submission-nick submission-nick (submit-data? submit-data?)
#:applications applications))) (wifi-submission-url wifi-submission-url)
(service (submission-nick submission-nick)
(documentation "Run the GeoClue location service.") (applications applications))))
(provision '(geoclue-daemon))
(requirement '(dbus-system))
(start #~(make-forkexec-constructor
(list (string-append #$geoclue "/libexec/geoclue"))
#:user "geoclue"
#:environment-variables
(list (string-append "GEOCLUE_CONFIG_FILE=" #$config))))
(stop #~(make-kill-destructor))
(user-groups (list (user-group
(name "geoclue")
(system? #t))))
(user-accounts (list (user-account
(name "geoclue")
(group "geoclue")
(system? #t)
(comment "GeoClue daemon user")
(home-directory "/var/empty")
(shell
"/run/current-system/profile/sbin/nologin")))))))
;;; ;;;
;;; Polkit privilege management service. ;;; Polkit privilege management service.
;;; ;;;
(define %polkit-accounts
(list (user-group (name "polkitd") (system? #t))
(user-account
(name "polkitd")
(group "polkitd")
(system? #t)
(comment "Polkit daemon user")
(home-directory "/var/empty")
(shell "/run/current-system/profile/sbin/nologin"))))
(define %polkit-pam-services
(list (unix-pam-service "polkit-1")))
(define (polkit-dmd-service polkit)
"Return the <dmd-service> for POLKIT."
;; TODO: Remove when D-Bus activation works.
(list (dmd-service
(documentation "Run the polkit privilege management service.")
(provision '(polkit-daemon))
(requirement '(dbus-system))
(start #~(make-forkexec-constructor
(list (string-append #$polkit "/lib/polkit-1/polkitd"))))
(stop #~(make-kill-destructor)))))
(define polkit-service-type
;; TODO: Make it extensible so it can collect policy files from other
;; services.
(service-type (name 'polkit)
(extensions
(list (service-extension account-service-type
(const %polkit-accounts))
(service-extension pam-root-service-type
(const %polkit-pam-services))
(service-extension dbus-root-service-type
list)
(service-extension dmd-root-service-type
polkit-dmd-service)))))
(define* (polkit-service #:key (polkit polkit)) (define* (polkit-service #:key (polkit polkit))
"Return a service that runs the @command{polkit} privilege management "Return a service that runs the @command{polkit} privilege management
service. By querying the @command{polkit} service, a privileged system service. By querying the @command{polkit} service, a privileged system
component can know when it should grant additional capabilities to ordinary component can know when it should grant additional capabilities to ordinary
users. For example, an ordinary user can be granted the capability to suspend users. For example, an ordinary user can be granted the capability to suspend
the system if the user is logged in locally." the system if the user is logged in locally."
(service (service polkit-service-type polkit))
(documentation "Run the polkit privilege management service.")
(provision '(polkit-daemon))
(requirement '(dbus-system))
(start #~(make-forkexec-constructor
(list (string-append #$polkit "/lib/polkit-1/polkitd"))))
(stop #~(make-kill-destructor))
(user-groups (list (user-group
(name "polkitd")
(system? #t))))
(user-accounts (list (user-account
(name "polkitd")
(group "polkitd")
(system? #t)
(comment "Polkit daemon user")
(home-directory "/var/empty")
(shell
"/run/current-system/profile/sbin/nologin"))))
(pam-services (list (unix-pam-service "polkit-1")))))
;;; ;;;
@ -418,6 +484,8 @@ the system if the user is logged in locally."
(define-record-type* <elogind-configuration> elogind-configuration (define-record-type* <elogind-configuration> elogind-configuration
make-elogind-configuration make-elogind-configuration
elogind-configuration elogind-configuration
(elogind elogind-package
(default elogind))
(kill-user-processes? elogind-kill-user-processes? (kill-user-processes? elogind-kill-user-processes?
(default #f)) (default #f))
(kill-only-users elogind-kill-only-users (kill-only-users elogind-kill-only-users
@ -547,15 +615,11 @@ the system if the user is logged in locally."
("HybridSleepState" (sleep-list elogind-hybrid-sleep-state)) ("HybridSleepState" (sleep-list elogind-hybrid-sleep-state))
("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode)))) ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode))))
(define* (elogind-service #:key (elogind elogind) (define (elogind-dmd-service config)
(config (elogind-configuration))) "Return a dmd service for elogind, using @var{config}."
"Return a service that runs the @command{elogind} login and seat management (let ((config-file (elogind-configuration-file config))
service. The @command{elogind} service integrates with PAM to allow other (elogind (elogind-package config)))
system components to know the set of logged-in users as well as their session (list (dmd-service
types (graphical, console, remote, etc.). It can also clean up after users
when they log out."
(let ((config-file (elogind-configuration-file config)))
(service
(documentation "Run the elogind login and seat management service.") (documentation "Run the elogind login and seat management service.")
(provision '(elogind)) (provision '(elogind))
(requirement '(dbus-system)) (requirement '(dbus-system))
@ -564,50 +628,49 @@ when they log out."
(list (string-append #$elogind "/libexec/elogind/elogind")) (list (string-append #$elogind "/libexec/elogind/elogind"))
#:environment-variables #:environment-variables
(list (string-append "ELOGIND_CONF_FILE=" #$config-file)))) (list (string-append "ELOGIND_CONF_FILE=" #$config-file))))
(stop #~(make-kill-destructor))))) (stop #~(make-kill-destructor))))))
(define elogind-service-type
(service-type (name 'elogind)
(extensions
(list (service-extension dmd-root-service-type
elogind-dmd-service)
(service-extension dbus-root-service-type
(compose list elogind-package))
(service-extension udev-service-type
(compose list elogind-package))
;; TODO: Extend polkit(?) and PAM.
))))
(define* (elogind-service #:key (config (elogind-configuration)))
"Return a service that runs the @command{elogind} login and seat management
service. The @command{elogind} service integrates with PAM to allow other
system components to know the set of logged-in users as well as their session
types (graphical, console, remote, etc.). It can also clean up after users
when they log out."
(service elogind-service-type config))
;;; ;;;
;;; The default set of desktop services. ;;; The default set of desktop services.
;;; ;;;
(define %desktop-services (define %desktop-services
;; List of services typically useful for a "desktop" use case. ;; List of services typically useful for a "desktop" use case.
(cons* (slim-service) (cons* (slim-service)
;; The D-Bus clique.
(avahi-service) (avahi-service)
(wicd-service) (wicd-service)
(upower-service) (upower-service)
;; FIXME: The colord, geoclue, and polkit services could all be
;; bus-activated by default, so they don't run at program startup.
;; However, user creation and /var/lib/colord creation happen at
;; service activation time, so we currently add them to the set of
;; default services.
(colord-service) (colord-service)
(geoclue-service) (geoclue-service)
(polkit-service) (polkit-service)
(elogind-service) (elogind-service)
(dbus-service (list avahi wicd upower colord geoclue polkit elogind)) (dbus-service)
(ntp-service) (ntp-service)
(map (lambda (service) %base-services))
(cond
;; Provide an nscd ready to use nss-mdns.
((memq 'nscd (service-provision service))
(nscd-service (nscd-configuration
(name-services (list nss-mdns)))))
;; Add more rules to udev-service.
;;
;; XXX Keep this in sync with the 'udev-service' call in
;; %base-services. Here we intend only to add 'upower',
;; 'colord', and 'elogind'.
((memq 'udev (service-provision service))
(udev-service #:rules
(list lvm2 fuse alsa-utils crda
upower colord elogind)))
(else service)))
%base-services)))
;;; desktop.scm ends here ;;; desktop.scm ends here

78
gnu/services/dmd.scm
View File

@ -22,13 +22,27 @@
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix derivations) ;imported-modules, etc. #:use-module (guix derivations) ;imported-modules, etc.
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu packages admin)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:export (dmd-configuration-file)) #:export (dmd-root-service-type
%dmd-root-service
dmd-service-type
dmd-service
dmd-service?
dmd-service-documentation
dmd-service-provision
dmd-service-requirement
dmd-service-respawn?
dmd-service-start
dmd-service-stop
dmd-service-auto-start?))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -36,6 +50,68 @@
;;; ;;;
;;; Code: ;;; Code:
(define (dmd-boot-gexp services)
(mlet %store-monad ((dmd-conf (dmd-configuration-file services)))
(return #~(begin
;; Keep track of the booted system.
(false-if-exception (delete-file "/run/booted-system"))
(symlink (readlink "/run/current-system")
"/run/booted-system")
;; Close any remaining open file descriptors to be on the safe
;; side. This must be the very last thing we do, because
;; Guile has internal FDs such as 'sleep_pipe' that need to be
;; alive.
(let loop ((fd 3))
(when (< fd 1024)
(false-if-exception (close-fdes fd))
(loop (+ 1 fd))))
;; Start dmd.
(execl (string-append #$dmd "/bin/dmd")
"dmd" "--config" #$dmd-conf)))))
(define dmd-root-service-type
(service-type
(name 'dmd-root)
;; Extending the root dmd service (aka. PID 1) happens by concatenating the
;; list of services provided by the extensions.
(compose concatenate)
(extend append)
(extensions (list (service-extension boot-service-type dmd-boot-gexp)))))
(define %dmd-root-service
;; The root dmd service, aka. PID 1. Its parameter is a list of
;; <dmd-service> objects.
(service dmd-root-service-type '()))
(define-syntax-rule (dmd-service-type proc)
"Return a <service-type> denoting a simple dmd service--i.e., the type for a
service that extends DMD-ROOT-SERVICE-TYPE and nothing else."
(service-type
(name 'some-dmd-service)
(extensions
(list (service-extension dmd-root-service-type
(compose list proc))))))
(define-record-type* <dmd-service>
dmd-service make-dmd-service
dmd-service?
(documentation service-documentation ; string
(default "[No documentation.]"))
(provision service-provision) ; list of symbols
(requirement service-requirement ; list of symbols
(default '()))
(respawn? service-respawn? ; Boolean
(default #t))
(start service-start) ; g-expression (procedure)
(stop service-stop ; g-expression (procedure)
(default #~(const #f)))
(auto-start? service-auto-start? ; Boolean
(default #t)))
(define (assert-no-duplicates services) (define (assert-no-duplicates services)
"Raise an error if SERVICES provide the same dmd service more than once. "Raise an error if SERVICES provide the same dmd service more than once.

68
gnu/services/lirc.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,29 +19,39 @@
(define-module (gnu services lirc) (define-module (gnu services lirc)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd)
#:use-module (gnu packages lirc) #:use-module (gnu packages lirc)
#:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix records)
#:use-module (ice-9 match)
#:export (lirc-service)) #:export (lirc-service))
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; LIRC services. ;;; LIRC service.
;;; ;;;
;;; Code: ;;; Code:
(define* (lirc-service #:key (lirc lirc) (define-record-type* <lirc-configuration>
device driver config-file lirc-configuration make-lirc-configuration
(extra-options '())) lirc-configuation?
"Return a service that runs @url{http://www.lirc.org,LIRC}, a daemon that (lirc lirc-configuration-lirc ;<package>
decodes infrared signals from remote controls. (default lirc))
(device lirc-configuration-device) ;string
(driver lirc-configuration-driver) ;string
(config-file lirc-configuration-file) ;string | file-like object
(extra-options lirc-configuration-options ;list of strings
(default '())))
The daemon will use specified @var{device}, @var{driver} and (define %lirc-activation
@var{config-file} (configuration file name). #~(begin
(use-modules (guix build utils))
(mkdir-p "/var/run/lirc")))
Finally, @var{extra-options} is a list of additional command-line options (define lirc-dmd-service
passed to @command{lircd}." (match-lambda
(service (($ <lirc-configuration> lirc device driver config-file options)
(list (dmd-service
(provision '(lircd)) (provision '(lircd))
(documentation "Run the LIRC daemon.") (documentation "Run the LIRC daemon.")
(requirement '(user-processes)) (requirement '(user-processes))
@ -56,10 +67,33 @@ passed to @command{lircd}."
#$@(if config-file #$@(if config-file
#~(#$config-file) #~(#$config-file)
#~()) #~())
#$@extra-options))) #$@options)))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor)))))))
(activate #~(begin
(use-modules (guix build utils)) (define lirc-service-type
(mkdir-p "/var/run/lirc"))))) (service-type (name 'lirc)
(extensions
(list (service-extension dmd-root-service-type
lirc-dmd-service)
(service-extension activation-service-type
(const %lirc-activation))))))
(define* (lirc-service #:key (lirc lirc)
device driver config-file
(extra-options '()))
"Return a service that runs @url{http://www.lirc.org,LIRC}, a daemon that
decodes infrared signals from remote controls.
The daemon will use specified @var{device}, @var{driver} and
@var{config-file} (configuration file name).
Finally, @var{extra-options} is a list of additional command-line options
passed to @command{lircd}."
(service lirc-service-type
(lirc-configuration
(lirc lirc)
(device device) (driver driver)
(config-file config-file)
(extra-options extra-options))))
;;; lirc.scm ends here ;;; lirc.scm ends here

316
gnu/services/networking.scm
View File

@ -19,7 +19,10 @@
(define-module (gnu services networking) (define-module (gnu services networking)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd)
#:use-module (gnu services dbus)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu system linux) ;PAM
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
#:use-module (gnu packages tor) #:use-module (gnu packages tor)
@ -27,8 +30,9 @@
#:use-module (gnu packages ntp) #:use-module (gnu packages ntp)
#:use-module (gnu packages wicd) #:use-module (gnu packages wicd)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix records)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (%facebook-host-aliases #:export (%facebook-host-aliases
static-networking-service static-networking-service
dhcp-client-service dhcp-client-service
@ -78,21 +82,26 @@ fe80::1%lo0 www.connect.facebook.net
fe80::1%lo0 apps.facebook.com\n") fe80::1%lo0 apps.facebook.com\n")
(define* (static-networking-service interface ip (define-record-type* <static-networking>
#:key static-networking make-static-networking
gateway static-networking?
(provision '(networking)) (interface static-networking-interface)
(name-servers '()) (ip static-networking-ip)
(net-tools net-tools)) (gateway static-networking-gateway)
"Return a service that starts @var{interface} with address @var{ip}. If (provision static-networking-provision)
@var{gateway} is true, it must be a string specifying the default network (name-servers static-networking-name-servers)
gateway." (net-tools static-networking-net-tools))
(define loopback?
(memq 'loopback provision)) (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 ;; TODO: Eventually replace 'route' with bindings for the appropriate
;; ioctls. ;; ioctls.
(service (dmd-service
;; Unless we're providing the loopback interface, wait for udev to be up ;; Unless we're providing the loopback interface, wait for udev to be up
;; and running so that INTERFACE is actually usable. ;; and running so that INTERFACE is actually usable.
@ -137,19 +146,34 @@ gateway."
"/sbin/route") "/sbin/route")
"del" "-net" "default") "del" "-net" "default")
#t)))) #t))))
(respawn? #f))) (respawn? #f)))))))
(define* (dhcp-client-service #:key (dhcp isc-dhcp)) (define* (static-networking-service interface ip
"Return a service that runs @var{dhcp}, a Dynamic Host Configuration #:key
Protocol (DHCP) client, on all the non-loopback network interfaces." gateway
(provision '(networking))
(name-servers '())
(net-tools net-tools))
"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."
(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 (define dhclient
#~(string-append #$dhcp "/sbin/dhclient")) #~(string-append #$dhcp "/sbin/dhclient"))
(define pid-file (define pid-file
"/var/run/dhclient.pid") "/var/run/dhclient.pid")
(service (dmd-service
(documentation "Set up networking via DHCP.") (documentation "Set up networking via DHCP.")
(requirement '(user-processes udev)) (requirement '(user-processes udev))
@ -191,7 +215,12 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
(sleep 1) (sleep 1)
(loop)) (loop))
(apply throw args)))))))))) (apply throw args))))))))))
(stop #~(make-kill-destructor)))) (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."
(service dhcp-client-service-type dhcp))
(define %ntp-servers (define %ntp-servers
;; Default set of NTP servers. ;; Default set of NTP servers.
@ -199,13 +228,24 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
"1.pool.ntp.org" "1.pool.ntp.org"
"2.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 ;;; NTP.
@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.
;; 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 (define config
(string-append "driftfile /var/run/ntp.drift\n" (string-append "driftfile /var/run/ntp.drift\n"
(string-join (map (cut string-append "server " <>) (string-join (map (cut string-append "server " <>)
@ -221,32 +261,63 @@ restrict -6 default kod nomodify notrap nopeer noquery
restrict 127.0.0.1 restrict 127.0.0.1
restrict -6 ::1\n")) restrict -6 ::1\n"))
(let ((ntpd.conf (plain-file "ntpd.conf" config))) (define ntpd.conf
(service (plain-file "ntpd.conf" config))
(list (dmd-service
(provision '(ntpd)) (provision '(ntpd))
(documentation "Run the Network Time Protocol (NTP) daemon.") (documentation "Run the Network Time Protocol (NTP) daemon.")
(requirement '(user-processes networking)) (requirement '(user-processes networking))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$ntp "/bin/ntpd") "-n" (list (string-append #$ntp "/bin/ntpd") "-n"
"-c" #$ntpd.conf "-c" #$ntpd.conf "-u" "ntpd")))
"-u" "ntpd"))) (stop #~(make-kill-destructor))))))))
(stop #~(make-kill-destructor))
(user-accounts (list (user-account (define %ntp-accounts
(list (user-account
(name "ntpd") (name "ntpd")
(group "nogroup") (group "nogroup")
(system? #t) (system? #t)
(comment "NTP daemon user") (comment "NTP daemon user")
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (shell #~(string-append #$shadow "/sbin/nologin")))))
#~(string-append #$shadow "/sbin/nologin"))))))))
(define* (tor-service #:key (tor tor)) (define ntp-service-type
"Return a service to run the @uref{https://torproject.org,Tor} daemon. (service-type (name 'ntp)
(extensions
(list (service-extension dmd-root-service-type
ntp-dmd-service)
(service-extension account-service-type
(const %ntp-accounts))))))
The daemon runs with the default settings (in particular the default exit (define* (ntp-service #:key (ntp ntp)
policy) as the @code{tor} unprivileged user." (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"))) (let ((torrc (plain-file "torrc" "User tor\n")))
(service (list (dmd-service
(provision '(tor)) (provision '(tor))
;; Tor needs at least one network interface to be up, hence the ;; Tor needs at least one network interface to be up, hence the
@ -256,20 +327,88 @@ policy) as the @code{tor} unprivileged user."
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$tor "/bin/tor") "-f" #$torrc))) (list (string-append #$tor "/bin/tor") "-f" #$torrc)))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(documentation "Run the Tor anonymous network overlay.")))))
(user-groups (list (user-group (define tor-service-type
(name "tor") (service-type (name 'tor)
(system? #t)))) (extensions
(user-accounts (list (user-account (list (service-extension dmd-root-service-type
(name "tor") tor-dmd-service)
(group "tor") (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."
(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) (system? #t)
(comment "Tor daemon user") (comment "BitlBee daemon user")
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (shell #~(string-append #$shadow "/sbin/nologin")))))
#~(string-append #$shadow "/sbin/nologin")))))
(documentation "Run the Tor anonymous network overlay.")))) (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) (define* (bitlbee-service #:key (bitlbee bitlbee)
(interface "127.0.0.1") (port 6667) (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 In addition, @var{extra-settings} specifies a string to append to the
configuration file." configuration file."
(let ((conf (plain-file "bitlbee.conf" (service bitlbee-service-type
(string-append " (bitlbee-configuration
[settings] (bitlbee bitlbee)
User = bitlbee (interface interface) (port port)
ConfigDir = /var/lib/bitlbee (extra-settings extra-settings))))
DaemonInterface = " interface "
DaemonPort = " (number->string port) "
" extra-settings)))) ;;;
(service ;;; Wicd.
(provision '(bitlbee)) ;;;
(requirement '(user-processes loopback))
(activate #~(begin (define %wicd-activation
;; Activation gexp for Wicd.
#~(begin
(use-modules (guix build utils)) (use-modules (guix build utils))
;; This directory is used to store OTR data. (mkdir-p "/etc/wicd")
(mkdir-p "/var/lib/bitlbee") (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
(let ((user (getpwnam "bitlbee"))) (unless (file-exists? file-name)
(chown "/var/lib/bitlbee" (copy-file (string-append #$wicd file-name)
(passwd:uid user) (passwd:gid user))))) file-name)))))
(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"))))))))
(define* (wicd-service #:key (wicd wicd)) (define (wicd-dmd-service wicd)
"Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network "Return a dmd service for WICD."
manager that aims to simplify wired and wireless networking." (list (dmd-service
(service
(documentation "Run the Wicd network manager.") (documentation "Run the Wicd network manager.")
(provision '(networking)) (provision '(networking))
(requirement '(user-processes dbus-system loopback)) (requirement '(user-processes dbus-system loopback))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$wicd "/sbin/wicd") (list (string-append #$wicd "/sbin/wicd")
"--no-daemon"))) "--no-daemon")))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor)))))
(activate
#~(begin (define wicd-service-type
(use-modules (guix build utils)) (service-type (name 'wicd)
(mkdir-p "/etc/wicd") (extensions
(let ((file-name "/etc/wicd/dhclient.conf.template.default")) (list (service-extension dmd-root-service-type
(unless (file-exists? file-name) wicd-dmd-service)
(copy-file (string-append #$wicd file-name) (service-extension dbus-root-service-type
file-name))))))) 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 wicd-service-type wicd))
;;; networking.scm ends here ;;; networking.scm ends here

178
gnu/services/ssh.scm
View File

@ -18,8 +18,9 @@
(define-module (gnu services ssh) (define-module (gnu services ssh)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix records)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd)
#:use-module (gnu system linux) ; 'pam-service' #:use-module (gnu system linux) ; 'pam-service'
#:use-module (gnu packages lsh) #:use-module (gnu packages lsh)
#:export (lsh-service)) #:export (lsh-service))
@ -30,11 +31,32 @@
;;; ;;;
;;; Code: ;;; Code:
;; TODO: Export.
(define-record-type* <lsh-configuration>
lsh-configuration make-lsh-configuration
lsh-configuration?
(lsh lsh-configuration-lsh
(default lsh))
(daemonic? lsh-configuration-daemonic?)
(host-key lsh-configuration-host-key)
(interfaces lsh-configuration-interfaces)
(port-number lsh-configuration-port-number)
(allow-empty-passwords? lsh-configuration-allow-empty-passwords?)
(root-login? lsh-configuration-root-login?)
(syslog-output? lsh-configuration-syslog-output?)
(pid-file? lsh-configuration-pid-file?)
(pid-file lsh-configuration-pid-file)
(x11-forwarding? lsh-configuration-x11-forwarding?)
(tcp/ip-forwarding? lsh-configuration-tcp/ip-forwarding?)
(password-authentication? lsh-configuration-password-authentication?)
(public-key-authentication? lsh-configuration-public-key-authentication?)
(initialize? lsh-configuration-initialize?))
(define %yarrow-seed (define %yarrow-seed
"/var/spool/lsh/yarrow-seed-file") "/var/spool/lsh/yarrow-seed-file")
(define (activation lsh host-key) (define (lsh-initialization lsh host-key)
"Return the gexp to activate the LSH service for HOST-KEY." "Return the gexp to initialize the LSH service for HOST-KEY."
#~(begin #~(begin
(unless (file-exists? #$%yarrow-seed) (unless (file-exists? #$%yarrow-seed)
(system* (string-append #$lsh "/bin/lsh-make-seed") (system* (string-append #$lsh "/bin/lsh-make-seed")
@ -70,6 +92,88 @@
(waitpid keygen) (waitpid keygen)
(waitpid write-key)))))))))) (waitpid write-key))))))))))
(define (lsh-activation config)
"Return the activation gexp for CONFIG."
#~(begin
(use-modules (guix build utils))
(mkdir-p "/var/spool/lsh")
#$(if (lsh-configuration-initialize? config)
(lsh-initialization (lsh-configuration-lsh config)
(lsh-configuration-host-key config))
#t)))
(define (lsh-dmd-service config)
"Return a <dmd-service> for lsh with CONFIG."
(define lsh (lsh-configuration-lsh config))
(define pid-file (lsh-configuration-pid-file config))
(define pid-file? (lsh-configuration-pid-file? config))
(define daemonic? (lsh-configuration-daemonic? config))
(define interfaces (lsh-configuration-interfaces config))
(define lsh-command
(append
(cons #~(string-append #$lsh "/sbin/lshd")
(if daemonic?
(let ((syslog (if (lsh-configuration-syslog-output? config)
'()
(list "--no-syslog"))))
(cons "--daemonic"
(if pid-file?
(cons #~(string-append "--pid-file=" #$pid-file)
syslog)
(cons "--no-pid-file" syslog))))
(if pid-file?
(list #~(string-append "--pid-file=" #$pid-file))
'())))
(cons* #~(string-append "--host-key="
#$(lsh-configuration-host-key config))
#~(string-append "--password-helper=" #$lsh "/sbin/lsh-pam-checkpw")
#~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server")
"-p" (number->string (lsh-configuration-port-number config))
(if (lsh-configuration-password-authentication? config)
"--password" "--no-password")
(if (lsh-configuration-public-key-authentication? config)
"--publickey" "--no-publickey")
(if (lsh-configuration-root-login? config)
"--root-login" "--no-root-login")
(if (lsh-configuration-x11-forwarding? config)
"--x11-forward" "--no-x11-forward")
(if (lsh-configuration-tcp/ip-forwarding? config)
"--tcpip-forward" "--no-tcpip-forward")
(if (null? interfaces)
'()
(list (string-append "--interfaces="
(string-join interfaces ",")))))))
(define requires
(if (and daemonic? (lsh-configuration-syslog-output? config))
'(networking syslogd)
'(networking)))
(list (dmd-service
(documentation "GNU lsh SSH server")
(provision '(ssh-daemon))
(requirement requires)
(start #~(make-forkexec-constructor (list #$@lsh-command)))
(stop #~(make-kill-destructor)))))
(define (lsh-pam-services config)
"Return a list of <pam-services> for lshd with CONFIG."
(list (unix-pam-service
"lshd"
#:allow-empty-passwords?
(lsh-configuration-allow-empty-passwords? config))))
(define lsh-service-type
(service-type (name 'lsh)
(extensions
(list (service-extension dmd-root-service-type
lsh-dmd-service)
(service-extension pam-root-service-type
lsh-pam-services)
(service-extension activation-service-type
lsh-activation)))))
(define* (lsh-service #:key (define* (lsh-service #:key
(lsh lsh) (lsh lsh)
(daemonic? #t) (daemonic? #t)
@ -114,58 +218,20 @@ passwords, and @var{root-login?} specifies whether to accept log-ins as
root. root.
The other options should be self-descriptive." The other options should be self-descriptive."
(define lsh-command (service lsh-service-type
(append (lsh-configuration (lsh lsh) (daemonic? daemonic?)
(cons #~(string-append #$lsh "/sbin/lshd") (host-key host-key) (interfaces interfaces)
(if daemonic? (port-number port-number)
(let ((syslog (if syslog-output? '() (allow-empty-passwords? allow-empty-passwords?)
(list "--no-syslog")))) (root-login? root-login?)
(cons "--daemonic" (syslog-output? syslog-output?)
(if pid-file? (pid-file? pid-file?) (pid-file pid-file)
(cons #~(string-append "--pid-file=" #$pid-file) (x11-forwarding? x11-forwarding?)
syslog) (tcp/ip-forwarding? tcp/ip-forwarding?)
(cons "--no-pid-file" syslog)))) (password-authentication?
(if pid-file? password-authentication?)
(list #~(string-append "--pid-file=" #$pid-file)) (public-key-authentication?
'()))) public-key-authentication?)
(cons* #~(string-append "--host-key=" #$host-key) (initialize? initialize?))))
#~(string-append "--password-helper=" #$lsh "/sbin/lsh-pam-checkpw")
#~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server")
"-p" (number->string port-number)
(if password-authentication? "--password" "--no-password")
(if public-key-authentication?
"--publickey" "--no-publickey")
(if root-login?
"--root-login" "--no-root-login")
(if x11-forwarding?
"--x11-forward" "--no-x11-forward")
(if tcp/ip-forwarding?
"--tcpip-forward" "--no-tcpip-forward")
(if (null? interfaces)
'()
(list (string-append "--interfaces="
(string-join interfaces ",")))))))
(define requires
(if (and daemonic? syslog-output?)
'(networking syslogd)
'(networking)))
(service
(documentation "GNU lsh SSH server")
(provision '(ssh-daemon))
(requirement requires)
(start #~(make-forkexec-constructor (list #$@lsh-command)))
(stop #~(make-kill-destructor))
(pam-services
(list (unix-pam-service
"lshd"
#:allow-empty-passwords? allow-empty-passwords?)))
(activate #~(begin
(use-modules (guix build utils))
(mkdir-p "/var/spool/lsh")
#$(if initialize?
(activation lsh host-key)
#t)))))
;;; ssh.scm ends here ;;; ssh.scm ends here

108
gnu/services/web.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,12 +19,13 @@
(define-module (gnu services web) (define-module (gnu services web)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages web) #:use-module (gnu packages web)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (ice-9 match)
#:export (nginx-service)) #:export (nginx-service))
;;; Commentary: ;;; Commentary:
@ -32,6 +34,14 @@
;;; ;;;
;;; Code: ;;; Code:
(define-record-type* <nginx-configuration>
nginx-configuration make-nginx-configuration
nginx-configuration?
(nginx nginx-configuration-nginx) ;<package>
(log-directory nginx-configuration-log-directory) ;string
(run-directory nginx-configuration-run-directory) ;string
(file nginx-configuration-file)) ;string | file-like
(define (default-nginx-config log-directory run-directory) (define (default-nginx-config log-directory run-directory)
(plain-file "nginx.conf" (plain-file "nginx.conf"
(string-append (string-append
@ -45,6 +55,58 @@
"}\n" "}\n"
"events {}\n"))) "events {}\n")))
(define %nginx-accounts
(list (user-group (name "nginx") (system? #t))
(user-account
(name "nginx")
(group "nginx")
(system? #t)
(comment "nginx server user")
(home-directory "/var/empty")
(shell #~(string-append #$shadow "/sbin/nologin")))))
(define nginx-activation
(match-lambda
(($ <nginx-configuration> nginx log-directory run-directory config-file)
#~(begin
(use-modules (guix build utils))
(format #t "creating nginx log directory '~a'~%" #$log-directory)
(mkdir-p #$log-directory)
(format #t "creating nginx run directory '~a'~%" #$run-directory)
(mkdir-p #$run-directory)
;; Check configuration file syntax.
(system* (string-append #$nginx "/bin/nginx")
"-c" #$config-file "-t")))))
(define nginx-dmd-service
(match-lambda
(($ <nginx-configuration> nginx log-directory run-directory config-file)
(let* ((nginx-binary #~(string-append #$nginx "/sbin/nginx"))
(nginx-action
(lambda args
#~(lambda _
(zero?
(system* #$nginx-binary "-c" #$config-file #$@args))))))
;; TODO: Add 'reload' action.
(list (dmd-service
(provision '(nginx))
(documentation "Run the nginx daemon.")
(requirement '(user-processes loopback))
(start (nginx-action "-p" run-directory))
(stop (nginx-action "-s" "stop"))))))))
(define nginx-service-type
(service-type (name 'nginx)
(extensions
(list (service-extension dmd-root-service-type
nginx-dmd-service)
(service-extension activation-service-type
nginx-activation)
(service-extension account-service-type
(const %nginx-accounts))))))
(define* (nginx-service #:key (nginx nginx) (define* (nginx-service #:key (nginx nginx)
(log-directory "/var/log/nginx") (log-directory "/var/log/nginx")
(run-directory "/var/run/nginx") (run-directory "/var/run/nginx")
@ -54,41 +116,9 @@
The nginx daemon loads its runtime configuration from CONFIG-FIGLE, stores log The nginx daemon loads its runtime configuration from CONFIG-FIGLE, stores log
files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY." files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY."
(define nginx-binary (service nginx-service-type
#~(string-append #$nginx "/sbin/nginx")) (nginx-configuration
(nginx nginx)
(define (nginx-action . args) (log-directory log-directory)
#~(lambda _ (run-directory run-directory)
(zero? (file config-file))))
(system* #$nginx-binary "-c" #$config-file #$@args))))
(define activate
#~(begin
(use-modules (guix build utils))
(format #t "creating nginx log directory '~a'~%" #$log-directory)
(mkdir-p #$log-directory)
(format #t "creating nginx run directory '~a'~%" #$run-directory)
(mkdir-p #$run-directory)
;; Check configuration file syntax.
(system* #$nginx-binary "-c" #$config-file "-t")))
(define nologin #~(string-append #$shadow "/sbin/nologin"))
;; TODO: Add 'reload' action.
(service
(provision '(nginx))
(documentation "Run the nginx daemon.")
(requirement '(user-processes loopback))
(start (nginx-action "-p" run-directory))
(stop (nginx-action "-s" "stop"))
(activate activate)
(user-groups (list (user-group
(name "nginx")
(system? #t))))
(user-accounts (list (user-account
(name "nginx")
(group "nginx")
(system? #t)
(comment "nginx server user")
(home-directory "/var/empty")
(shell nologin))))))

148
gnu/services/xorg.scm
View File

@ -20,6 +20,7 @@
(define-module (gnu services xorg) (define-module (gnu services xorg)
#:use-module (gnu artwork) #:use-module (gnu artwork)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd)
#:use-module (gnu system linux) ; 'pam-service' #:use-module (gnu system linux) ; 'pam-service'
#:use-module ((gnu packages base) #:select (canonical-package)) #:use-module ((gnu packages base) #:select (canonical-package))
#:use-module (gnu packages guile) #:use-module (gnu packages guile)
@ -212,6 +213,95 @@ which should be passed to this script as the first argument. If not, the
;; contains the actual theme files. ;; contains the actual theme files.
"0.x") "0.x")
(define-record-type* <slim-configuration>
slim-configuration make-slim-configuration
slim-configuration?
(slim slim-configuration-slim
(default slim))
(allow-empty-passwords? slim-configuration-allow-empty-passwords?)
(auto-login? slim-configuration-auto-login?)
(default-user slim-configuration-default-user)
(theme slim-configuration-theme)
(theme-name slim-configuration-theme-name)
(xauth slim-configuration-xauth
(default xauth))
(dmd slim-configuration-dmd
(default dmd))
(bash slim-configuration-bash
(default bash))
(auto-login-session slim-configuration-auto-login-session)
(startx slim-configuration-startx))
(define (slim-pam-service config)
"Return a PAM service for @command{slim}."
(list (unix-pam-service
"slim"
#:allow-empty-passwords?
(slim-configuration-allow-empty-passwords? config))))
(define (slim-dmd-service config)
(define slim.cfg
(let ((xinitrc (xinitrc #:fallback-session
(slim-configuration-auto-login-session config)))
(slim (slim-configuration-slim config))
(xauth (slim-configuration-xauth config))
(startx (slim-configuration-startx config))
(dmd (slim-configuration-dmd config))
(theme-name (slim-configuration-theme-name config)))
(mixed-text-file "slim.cfg" "
default_path /run/current-system/profile/bin
default_xserver " startx "
xserver_arguments :0 vt7
xauth_path " xauth "/bin/xauth
authfile /var/run/slim.auth
# The login command. '%session' is replaced by the chosen session name, one
# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc.
login_cmd exec " xinitrc " %session
sessiondir /run/current-system/profile/share/xsessions
session_msg session (F1 to change):
halt_cmd " dmd "/sbin/halt
reboot_cmd " dmd "/sbin/reboot\n"
(if (slim-configuration-auto-login? config)
(string-append "auto_login yes\ndefault_user "
(slim-configuration-default-user config) "\n")
"")
(if theme-name
(string-append "current_theme " theme-name "\n")
""))))
(define theme
(slim-configuration-theme config))
(list (dmd-service
(documentation "Xorg display server")
(provision '(xorg-server))
(requirement '(user-processes host-name udev))
(start
#~(lambda ()
;; A stale lock file can prevent SLiM from starting, so remove it to
;; be on the safe side.
(false-if-exception (delete-file "/var/run/slim.lock"))
(fork+exec-command
(list (string-append #$slim "/bin/slim") "-nodaemon")
#:environment-variables
(list (string-append "SLIM_CFGFILE=" #$slim.cfg)
#$@(if theme
(list #~(string-append "SLIM_THEMESDIR=" #$theme))
#~())))))
(stop #~(make-kill-destructor))
(respawn? #t))))
(define slim-service-type
(service-type (name 'slim)
(extensions
(list (service-extension dmd-root-service-type
slim-dmd-service)
(service-extension pam-root-service-type
slim-pam-service)))))
(define* (slim-service #:key (slim slim) (define* (slim-service #:key (slim slim)
(allow-empty-passwords? #t) auto-login? (allow-empty-passwords? #t) auto-login?
(default-user "") (default-user "")
@ -246,54 +336,14 @@ If @var{theme} is @code{#f}, the use the default log-in theme; otherwise
@var{theme} must be a gexp denoting the name of a directory containing the @var{theme} must be a gexp denoting the name of a directory containing the
theme to use. In that case, @var{theme-name} specifies the name of the theme to use. In that case, @var{theme-name} specifies the name of the
theme." theme."
(service slim-service-type
(define slim.cfg (slim-configuration
(let ((xinitrc (xinitrc #:fallback-session auto-login-session))) (slim slim)
(mixed-text-file "slim.cfg" " (allow-empty-passwords? allow-empty-passwords?)
default_path /run/current-system/profile/bin (auto-login? auto-login?) (default-user default-user)
default_xserver " startx " (theme theme) (theme-name theme-name)
xserver_arguments :0 vt7 (xauth xauth) (dmd dmd) (bash bash)
xauth_path " xauth "/bin/xauth (auto-login-session auto-login-session)
authfile /var/run/slim.auth (startx startx))))
# The login command. '%session' is replaced by the chosen session name, one
# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc.
login_cmd exec " xinitrc " %session
sessiondir /run/current-system/profile/share/xsessions
session_msg session (F1 to change):
halt_cmd " dmd "/sbin/halt
reboot_cmd " dmd "/sbin/reboot\n"
(if auto-login?
(string-append "auto_login yes\ndefault_user " default-user "\n")
"")
(if theme-name
(string-append "current_theme " theme-name "\n")
""))))
(service
(documentation "Xorg display server")
(provision '(xorg-server))
(requirement '(user-processes host-name udev))
(start
#~(lambda ()
;; A stale lock file can prevent SLiM from starting, so remove it
;; to be on the safe side.
(false-if-exception (delete-file "/var/run/slim.lock"))
(fork+exec-command
(list (string-append #$slim "/bin/slim") "-nodaemon")
#:environment-variables
(list (string-append "SLIM_CFGFILE=" #$slim.cfg)
#$@(if theme
(list #~(string-append "SLIM_THEMESDIR=" #$theme))
#~())))))
(stop #~(make-kill-destructor))
(respawn? #t)
(pam-services
;; Tell PAM about 'slim'.
(list (unix-pam-service
"slim"
#:allow-empty-passwords? allow-empty-passwords?)))))
;;; xorg.scm ends here ;;; xorg.scm ends here

357
gnu/system.scm
View File

@ -87,8 +87,6 @@
operating-system-locale-directory operating-system-locale-directory
operating-system-boot-script operating-system-boot-script
file-union
local-host-aliases local-host-aliases
%setuid-programs %setuid-programs
%base-packages %base-packages
@ -160,41 +158,6 @@
(sudoers-file operating-system-sudoers-file ; file-like (sudoers-file operating-system-sudoers-file ; file-like
(default %sudoers-specification))) (default %sudoers-specification)))
;;;
;;; Derivation.
;;;
(define* (file-union name files)
"Return a derivation that builds a directory containing all of FILES. Each
item in FILES must be a list where the first element is the file name to use
in the new directory, and the second element is a gexp denoting the target
file."
(define builder
#~(begin
(mkdir #$output)
(chdir #$output)
#$@(map (match-lambda
((target source)
#~(symlink #$source #$target)))
files)))
(gexp->derivation name builder))
(define (directory-union name things)
"Return a directory that is the union of THINGS."
(match things
((one)
;; Only one thing; return it.
(with-monad %store-monad (return one)))
(_
(gexp->derivation name
#~(begin
(use-modules (guix build union))
(union-build #$output '#$things))
#:modules '((guix build union))
#:local-build? #t))))
;;; ;;;
;;; Services. ;;; Services.
@ -244,18 +207,7 @@ as 'needed-for-boot'."
(string->symbol (mapped-device-target md)))) (string->symbol (mapped-device-target md))))
(device-mappings fs)))) (device-mappings fs))))
(map (lambda (fs) (map file-system-service file-systems))
(match fs
(($ <file-system> device title target type flags opts
#f check? create?)
(file-system-service device target type
#:title title
#:requirements (requirements fs)
#:check? check?
#:create-mount-point? create?
#:options opts
#:flags flags))))
file-systems))
(define (mapped-device-user device file-systems) (define (mapped-device-user device file-systems)
"Return a file system among FILE-SYSTEMS that uses DEVICE, or #f." "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
@ -302,10 +254,11 @@ from the initrd."
"Return the list of swap services for OS." "Return the list of swap services for OS."
(map swap-service (operating-system-swap-devices os))) (map swap-service (operating-system-swap-devices os)))
(define (essential-services os) (define* (essential-services os #:key container?)
"Return the list of essential services for OS. These are special services "Return the list of essential services for OS. These are special services
that implement part of what's declared in OS are responsible for low-level that implement part of what's declared in OS are responsible for low-level
bookkeeping." bookkeeping. CONTAINER? determines whether to return the list of services for
a container or that of a \"bare metal\" system."
(define known-fs (define known-fs
(map file-system-mount-point (operating-system-file-systems os))) (map file-system-mount-point (operating-system-file-systems os)))
@ -315,17 +268,36 @@ bookkeeping."
(unmount (user-unmount-service known-fs)) (unmount (user-unmount-service known-fs))
(swaps (swap-services os)) (swaps (swap-services os))
(procs (user-processes-service (procs (user-processes-service
(map (compose first service-provision) (map service-parameters other-fs)))
other-fs)))
(host-name (host-name-service (operating-system-host-name os)))) (host-name (host-name-service (operating-system-host-name os))))
(cons* host-name procs root-fs unmount (cons* %boot-service
(append other-fs mappings swaps))))
(define (operating-system-services os) ;; %DMD-ROOT-SERVICE must come first so that the gexp that execs
;; dmd comes last in the boot script (XXX).
%dmd-root-service %activation-service
(pam-root-service (operating-system-pam-services os))
(account-service (append (operating-system-accounts os)
(operating-system-groups os))
(operating-system-skeletons os))
(operating-system-etc-service os)
host-name procs root-fs unmount
(service setuid-program-service-type
(operating-system-setuid-programs os))
(append other-fs mappings swaps
;; Add the firmware service, unless we are building for a
;; container.
(if container?
'()
(list (service firmware-service-type
(operating-system-firmware os))))))))
(define* (operating-system-services os #:key container?)
"Return all the services of OS, including \"internal\" services that do not "Return all the services of OS, including \"internal\" services that do not
explicitly appear in OS." explicitly appear in OS."
(append (operating-system-user-services os) (append (operating-system-user-services os)
(essential-services os))) (essential-services os #:container? container?)))
;;; ;;;
@ -388,7 +360,7 @@ This is the GNU system. Welcome.\n")
(define (emacs-site-file) (define (emacs-site-file)
"Return the Emacs 'site-start.el' file. That file contains the necessary "Return the Emacs 'site-start.el' file. That file contains the necessary
settings for 'guix.el' to work out-of-the-box." settings for 'guix.el' to work out-of-the-box."
(gexp->file "site-start.el" (scheme-file "site-start.el"
#~(progn #~(progn
;; Add the "normal" elisp directory to the search path; ;; Add the "normal" elisp directory to the search path;
;; guix.el may be there. ;; guix.el may be there.
@ -404,12 +376,11 @@ settings for 'guix.el' to work out-of-the-box."
(define (emacs-site-directory) (define (emacs-site-directory)
"Return the Emacs site directory, aka. /etc/emacs." "Return the Emacs site directory, aka. /etc/emacs."
(mlet %store-monad ((file (emacs-site-file))) (computed-file "emacs"
(gexp->derivation "emacs"
#~(begin #~(begin
(mkdir #$output) (mkdir #$output)
(chdir #$output) (chdir #$output)
(symlink #$file "site-start.el"))))) (symlink #$(emacs-site-file) "site-start.el"))))
(define (user-shells os) (define (user-shells os)
"Return the list of all the shells used by the accounts of OS. These may be "Return the list of all the shells used by the accounts of OS. These may be
@ -417,9 +388,9 @@ gexps or strings."
(map user-account-shell (operating-system-accounts os))) (map user-account-shell (operating-system-accounts os)))
(define (shells-file shells) (define (shells-file shells)
"Return a derivation that builds a shell list for use as /etc/shells based "Return a file-like object that builds a shell list for use as /etc/shells
on SHELLS. /etc/shells is used by xterm, polkit, and other programs." based on SHELLS. /etc/shells is used by xterm, polkit, and other programs."
(gexp->derivation "shells" (computed-file "shells"
#~(begin #~(begin
(use-modules (srfi srfi-1)) (use-modules (srfi srfi-1))
@ -437,29 +408,23 @@ on SHELLS. /etc/shells is used by xterm, polkit, and other programs."
(newline port)) (newline port))
shells)))))) shells))))))
(define* (etc-directory #:key (define* (operating-system-etc-service os)
(locale "C") (timezone "Europe/Paris") "Return a <service> that builds containing the static part of the /etc
(issue "Hello!\n") directory."
(skeletons '()) (let ((login.defs (plain-file "login.defs" "# Empty for now.\n"))
(pam-services '())
(profile "/run/current-system/profile") (shells (shells-file (user-shells os)))
hosts-file nss (shells '())
(sudoers-file (plain-file "sudoers" "")))
"Return a derivation that builds the static part of the /etc directory."
(mlet* %store-monad
((pam.d -> (pam-services->directory pam-services))
(login.defs (text-file "login.defs" "# Empty for now.\n"))
(shells (shells-file shells))
(emacs (emacs-site-directory)) (emacs (emacs-site-directory))
(issue (text-file "issue" issue)) (issue (plain-file "issue" (operating-system-issue os)))
(nsswitch (text-file "nsswitch.conf" (nsswitch (plain-file "nsswitch.conf"
(name-service-switch->string nss))) (name-service-switch->string
(operating-system-name-service-switch os))))
;; Startup file for POSIX-compliant login shells, which set system-wide ;; Startup file for POSIX-compliant login shells, which set system-wide
;; environment variables. ;; environment variables.
(profile (text-file* "profile" "\ (profile (mixed-text-file "profile" "\
export LANG=\"" locale "\" export LANG=\"" (operating-system-locale os) "\"
export TZ=\"" timezone "\" export TZ=\"" (operating-system-timezone os) "\"
export TZDIR=\"" tzdata "/share/zoneinfo\" export TZDIR=\"" tzdata "/share/zoneinfo\"
# Tell 'modprobe' & co. where to look for modules. # Tell 'modprobe' & co. where to look for modules.
@ -516,7 +481,7 @@ then
fi fi
")) "))
(bashrc (text-file "bashrc" "\ (bashrc (plain-file "bashrc" "\
# Bash-specific initialization. # Bash-specific initialization.
# The 'bash-completion' package. # The 'bash-completion' package.
@ -526,25 +491,23 @@ then
# completion loader that searches its own completion files as well # completion loader that searches its own completion files as well
# as those in ~/.guix-profile and /run/current-system/profile. # as those in ~/.guix-profile and /run/current-system/profile.
source /run/current-system/profile/etc/profile.d/bash_completion.sh source /run/current-system/profile/etc/profile.d/bash_completion.sh
fi\n")) fi\n")))
(skel -> (skeleton-directory skeletons))) (etc-service
(file-union "etc"
`(("services" ,#~(string-append #$net-base "/etc/services")) `(("services" ,#~(string-append #$net-base "/etc/services"))
("protocols" ,#~(string-append #$net-base "/etc/protocols")) ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
("rpc" ,#~(string-append #$net-base "/etc/rpc")) ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
("emacs" ,#~#$emacs) ("emacs" ,#~#$emacs)
("pam.d" ,#~#$pam.d)
("login.defs" ,#~#$login.defs) ("login.defs" ,#~#$login.defs)
("issue" ,#~#$issue) ("issue" ,#~#$issue)
("nsswitch.conf" ,#~#$nsswitch) ("nsswitch.conf" ,#~#$nsswitch)
("skel" ,#~#$skel)
("shells" ,#~#$shells) ("shells" ,#~#$shells)
("profile" ,#~#$profile) ("profile" ,#~#$profile)
("bashrc" ,#~#$bashrc) ("bashrc" ,#~#$bashrc)
("hosts" ,#~#$hosts-file) ("hosts" ,#~#$(or (operating-system-hosts-file os)
(default-/etc/hosts (operating-system-host-name os))))
("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
#$timezone)) #$(operating-system-timezone os)))
("sudoers" ,sudoers-file))))) ("sudoers" ,(operating-system-sudoers-file os))))))
(define (operating-system-profile os) (define (operating-system-profile os)
"Return a derivation that builds the system profile of OS." "Return a derivation that builds the system profile of OS."
@ -561,8 +524,8 @@ fi\n"))
(home-directory "/root"))) (home-directory "/root")))
(define (operating-system-accounts os) (define (operating-system-accounts os)
"Return the user accounts for OS, including an obligatory 'root' account." "Return the user accounts for OS, including an obligatory 'root' account,
(define users and excluding accounts requested by services."
;; Make sure there's a root account. ;; Make sure there's a root account.
(if (find (lambda (user) (if (find (lambda (user)
(and=> (user-account-uid user) zero?)) (and=> (user-account-uid user) zero?))
@ -570,10 +533,6 @@ fi\n"))
(operating-system-users os) (operating-system-users os)
(cons %root-account (operating-system-users os)))) (cons %root-account (operating-system-users os))))
(append users
(append-map service-user-accounts
(operating-system-services os))))
(define (maybe-string->file file-name thing) (define (maybe-string->file file-name thing)
"If THING is a string, return a <plain-file> with THING as its content. "If THING is a string, return a <plain-file> with THING as its content.
Otherwise just return THING. Otherwise just return THING.
@ -607,31 +566,9 @@ use 'plain-file' instead~%")
(define (operating-system-etc-directory os) (define (operating-system-etc-directory os)
"Return that static part of the /etc directory of OS." "Return that static part of the /etc directory of OS."
(mlet* %store-monad (etc-directory
((services -> (operating-system-services os)) (fold-services (operating-system-services os)
(pam-services -> #:target-type etc-service-type)))
;; Services known to PAM.
(append (operating-system-pam-services os)
(append-map service-pam-services services)))
(profile-drv (operating-system-profile os))
(skeletons (operating-system-skeletons os))
(/etc/hosts (maybe-file->monadic
"hosts"
(or (operating-system-hosts-file os)
(default-/etc/hosts (operating-system-host-name os)))))
(shells -> (user-shells os)))
(etc-directory #:pam-services pam-services
#:skeletons skeletons
#:issue (operating-system-issue os)
#:locale (operating-system-locale os)
#:nss (operating-system-name-service-switch os)
#:timezone (operating-system-timezone os)
#:hosts-file /etc/hosts
#:shells shells
#:sudoers-file (maybe-string->file
"sudoers"
(operating-system-sudoers-file os))
#:profile profile-drv)))
(define %setuid-programs (define %setuid-programs
;; Default set of setuid-root programs. ;; Default set of setuid-root programs.
@ -652,176 +589,23 @@ use 'plain-file' instead~%")
root ALL=(ALL) ALL root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n")) %wheel ALL=(ALL) ALL\n"))
(define (user-group->gexp group)
"Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
'active-groups'."
#~(list #$(user-group-name group)
#$(user-group-password group)
#$(user-group-id group)
#$(user-group-system? group)))
(define (user-account->gexp account)
"Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
'activate-users'."
#~`(#$(user-account-name account)
#$(user-account-uid account)
#$(user-account-group account)
#$(user-account-supplementary-groups account)
#$(user-account-comment account)
#$(user-account-home-directory account)
,#$(user-account-shell account) ; this one is a gexp
#$(user-account-password account)
#$(user-account-system? account)))
(define (modprobe-wrapper)
"Return a wrapper for the 'modprobe' command that knows where modules live.
This wrapper is typically invoked by the Linux kernel ('call_modprobe', in
kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment
variable is not set---hence the need for this wrapper."
(let ((modprobe "/run/current-system/profile/bin/modprobe"))
(gexp->script "modprobe"
#~(begin
(setenv "LINUX_MODULE_DIRECTORY"
"/run/booted-system/kernel/lib/modules")
(apply execl #$modprobe
(cons #$modprobe (cdr (command-line))))))))
(define* (operating-system-activation-script os #:key container?) (define* (operating-system-activation-script os #:key container?)
"Return the activation script for OS---i.e., the code that \"activates\" the "Return the activation script for OS---i.e., the code that \"activates\" the
stateful part of OS, including user accounts and groups, special directories, stateful part of OS, including user accounts and groups, special directories,
etc." etc."
(define %modules (let* ((services (operating-system-services os #:container? container?))
'((gnu build activation) (activation (fold-services services
(gnu build linux-boot) #:target-type activation-service-type)))
(gnu build linux-modules) (activation-service->script activation)))
(gnu build file-systems)
(guix build utils)
(guix build syscalls)
(guix elf)))
(define (service-activations services)
;; Return the activation scripts for SERVICES.
(let ((gexps (filter-map service-activate services)))
(sequence %store-monad (map (cut gexp->file "activate-service.scm" <>)
gexps))))
(mlet* %store-monad ((services -> (operating-system-services os))
(actions (service-activations services))
(etc (operating-system-etc-directory os))
(modules (imported-modules %modules))
(compiled (compiled-modules %modules))
(modprobe (modprobe-wrapper))
(firmware (directory-union
"firmware" (operating-system-firmware os)))
(accounts -> (operating-system-accounts os)))
(define setuid-progs
(operating-system-setuid-programs os))
(define user-specs
(map user-account->gexp accounts))
(define groups
(append (operating-system-groups os)
(append-map service-user-groups services)))
(define group-specs
(map user-group->gexp groups))
(assert-valid-users/groups accounts groups)
(gexp->file "activate"
#~(begin
(eval-when (expand load eval)
;; Make sure 'use-modules' below succeeds.
(set! %load-path (cons #$modules %load-path))
(set! %load-compiled-path
(cons #$compiled %load-compiled-path)))
(use-modules (gnu build activation))
;; Make sure /bin/sh is valid and current.
(activate-/bin/sh
(string-append #$(canonical-package bash)
"/bin/sh"))
;; Populate /etc.
(activate-etc #$etc)
;; Add users and user groups.
(setenv "PATH"
(string-append #$(@ (gnu packages admin) shadow)
"/sbin"))
(activate-users+groups (list #$@user-specs)
(list #$@group-specs))
;; Activate setuid programs.
(activate-setuid-programs (list #$@setuid-progs))
;; Tell the kernel to use our 'modprobe' command.
(activate-modprobe #$modprobe)
;; Tell the kernel where firmware is, unless we are
;; activating a container.
#$@(if container?
#~()
;; Tell the kernel where firmware is.
#~((activate-firmware
(string-append #$firmware "/lib/firmware"))
;; Let users debug their own processes!
(activate-ptrace-attach)))
;; Run the services' activation snippets.
;; TODO: Use 'load-compiled'.
(for-each primitive-load '#$actions)
;; Set up /run/current-system.
(activate-current-system)))))
(define* (operating-system-boot-script os #:key container?) (define* (operating-system-boot-script os #:key container?)
"Return the boot script for OS---i.e., the code started by the initrd once "Return the boot script for OS---i.e., the code started by the initrd once
we're running in the final root. When CONTAINER? is true, skip all we're running in the final root. When CONTAINER? is true, skip all
hardware-related operations as necessary when booting a Linux container." hardware-related operations as necessary when booting a Linux container."
(mlet* %store-monad ((services -> (operating-system-services os)) (let* ((services (operating-system-services os #:container? container?))
(activate (operating-system-activation-script os)) (boot (fold-services services)))
(dmd-conf (dmd-configuration-file services))) ;; BOOT is the script as a monadic value.
(gexp->file "boot" (service-parameters boot)))
#~(begin
(use-modules (guix build utils))
;; Clean out /tmp and /var/run.
;;
;; XXX This needs to happen before service activations, so
;; it has to be here, but this also implicitly assumes
;; that /tmp and /var/run are on the root partition.
(false-if-exception (delete-file-recursively "/tmp"))
(false-if-exception (delete-file-recursively "/var/run"))
(false-if-exception (mkdir "/tmp"))
(false-if-exception (chmod "/tmp" #o1777))
(false-if-exception (mkdir "/var/run"))
(false-if-exception (chmod "/var/run" #o755))
;; Activate the system.
;; TODO: Use 'load-compiled'.
(primitive-load #$activate)
;; Keep track of the booted system.
(false-if-exception (delete-file "/run/booted-system"))
(symlink (readlink "/run/current-system")
"/run/booted-system")
;; Close any remaining open file descriptors to be on the
;; safe side. This must be the very last thing we do,
;; because Guile has internal FDs such as 'sleep_pipe'
;; that need to be alive.
(let loop ((fd 3))
(when (< fd 1024)
(false-if-exception (close-fdes fd))
(loop (+ 1 fd))))
;; Start dmd.
(execl (string-append #$dmd "/bin/dmd")
"dmd" "--config" #$dmd-conf)))))
(define (operating-system-root-file-system os) (define (operating-system-root-file-system os)
"Return the root file system of OS." "Return the root file system of OS."
@ -908,12 +692,13 @@ this file is the reconstruction of GRUB menu entries for old configurations."
"Return a derivation that builds OS." "Return a derivation that builds OS."
(mlet* %store-monad (mlet* %store-monad
((profile (operating-system-profile os)) ((profile (operating-system-profile os))
(etc (operating-system-etc-directory os)) (etc -> (operating-system-etc-directory os))
(boot (operating-system-boot-script os)) (boot (operating-system-boot-script os))
(kernel -> (operating-system-kernel os)) (kernel -> (operating-system-kernel os))
(initrd (operating-system-initrd-file os)) (initrd (operating-system-initrd-file os))
(locale (operating-system-locale-directory os)) (locale (operating-system-locale-directory os))
(params (operating-system-parameters-file os))) (params (operating-system-parameters-file os)))
(lower-object
(file-union "system" (file-union "system"
`(("boot" ,#~#$boot) `(("boot" ,#~#$boot)
("kernel" ,#~#$kernel) ("kernel" ,#~#$kernel)
@ -921,6 +706,6 @@ this file is the reconstruction of GRUB menu entries for old configurations."
("initrd" ,initrd) ("initrd" ,initrd)
("profile" ,#~#$profile) ("profile" ,#~#$profile)
("locale" ,#~#$locale) ;used by libc ("locale" ,#~#$locale) ;used by libc
("etc" ,#~#$etc))))) ("etc" ,#~#$etc))))))
;;; system.scm ends here ;;; system.scm ends here

87
gnu/system/install.scm
View File

@ -24,6 +24,7 @@
#:use-module (guix monads) #:use-module (guix monads)
#:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix store) #:select (%store-prefix))
#:use-module (guix profiles) #:use-module (guix profiles)
#:use-module (gnu services dmd)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
@ -159,11 +160,10 @@ current store is on a RAM disk."
(mount "/.rw-store" #$(%store-prefix) "" MS_MOVE) (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE)
(rmdir "/.rw-store")))))) (rmdir "/.rw-store"))))))
(define (cow-store-service) (define cow-store-service-type
"Return a service that makes the store copy-on-write, such that writes go to (dmd-service-type
the user's target storage device rather than on the RAM disk." (lambda _
;; See <http://bugs.gnu.org/18061> for the initial report. (dmd-service
(service
(requirement '(root-file-system user-processes)) (requirement '(root-file-system user-processes))
(provision '(cow-store)) (provision '(cow-store))
(documentation (documentation
@ -182,45 +182,52 @@ the given target.")
#f))) #f)))
(stop #~(lambda (target) (stop #~(lambda (target)
;; Delete the temporary directory, but leave everything ;; Delete the temporary directory, but leave everything
;; mounted as there may still be processes using it ;; mounted as there may still be processes using it since
;; since 'user-processes' doesn't depend on us. The ;; 'user-processes' doesn't depend on us. The 'user-unmount'
;; 'user-unmount' service will unmount TARGET ;; service will unmount TARGET eventually.
;; eventually.
(delete-file-recursively (delete-file-recursively
(string-append target #$%backing-directory)))))) (string-append target #$%backing-directory))))))))
(define (configuration-template-service) (define (cow-store-service)
"Return a dummy service whose purpose is to install an operating system "Return a service that makes the store copy-on-write, such that writes go to
configuration template file in the installation system." the user's target storage device rather than on the RAM disk."
;; See <http://bugs.gnu.org/18061> for the initial report.
(service cow-store-service-type 'mooooh!))
(define search
(cut search-path %load-path <>))
(define templates
(map (match-lambda
((file '-> target)
(list (local-file (search file))
(string-append "/etc/configuration/" target))))
'(("gnu/system/examples/bare-bones.tmpl" -> "bare-bones.scm")
("gnu/system/examples/desktop.tmpl" -> "desktop.scm"))))
(service (define (/etc/configuration-files _)
(requirement '(root-file-system)) "Return a list of tuples representing configuration templates to add to
(provision '(os-config-template)) /etc."
(documentation (define (file f)
"This dummy service installs an OS configuration template.") (local-file (search-path %load-path
(start #~(const #t)) (string-append "gnu/system/examples/" f))))
(stop #~(const #f))
(activate (define directory
(computed-file "configuration-templates"
#~(begin #~(begin
(use-modules (ice-9 match) (mkdir #$output)
(guix build utils)) (for-each (lambda (file target)
(copy-file file
(string-append #$output "/"
target)))
'(#$(file "bare-bones.tmpl")
#$(file "desktop.tmpl"))
'("bare-bones.scm"
"desktop.scm"))
#t)
#:modules '((guix build utils))))
`(("configuration" ,directory)))
(define configuration-template-service-type
(service-type (name 'configuration-template)
(extensions
(list (service-extension etc-service-type
/etc/configuration-files)))))
(define %configuration-template-service
(service configuration-template-service-type #t))
(mkdir-p "/etc/configuration")
(for-each (match-lambda
((file target)
(unless (file-exists? target)
(copy-file file target))))
'#$templates)))))
(define %nscd-minimal-caches (define %nscd-minimal-caches
;; Minimal in-memory caching policy for nscd. ;; Minimal in-memory caching policy for nscd.
@ -262,7 +269,7 @@ You have been warned. Thanks for being so brave.
(login-program (log-to-info)))) (login-program (log-to-info))))
;; Documentation add-on. ;; Documentation add-on.
(configuration-template-service) %configuration-template-service
;; A bunch of 'root' ttys. ;; A bunch of 'root' ttys.
(normal-tty "tty3") (normal-tty "tty3")
@ -276,7 +283,7 @@ You have been warned. Thanks for being so brave.
;; The build daemon. Register the hydra.gnu.org key as trusted. ;; The build daemon. Register the hydra.gnu.org key as trusted.
;; This allows the installation process to use substitutes by ;; This allows the installation process to use substitutes by
;; default. ;; default.
(guix-service #:authorize-hydra-key? #t) (guix-service (guix-configuration (authorize-key? #t)))
;; Start udev so that useful device nodes are available. ;; Start udev so that useful device nodes are available.
;; Use device-mapper rules for cryptsetup & co; enable the CRDA for ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for

26
gnu/system/linux.scm
View File

@ -20,6 +20,7 @@
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (gnu services)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -28,7 +29,10 @@
pam-entry pam-entry
pam-services->directory pam-services->directory
unix-pam-service unix-pam-service
base-pam-services)) base-pam-services
pam-root-service-type
pam-root-service))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -188,4 +192,24 @@ authenticate to run COMMAND."
'("useradd" "userdel" "usermod" '("useradd" "userdel" "usermod"
"groupadd" "groupdel" "groupmod")))) "groupadd" "groupdel" "groupmod"))))
;;;
;;; PAM root service.
;;;
(define (/etc-entry services)
`(("pam.d" ,(pam-services->directory services))))
(define pam-root-service-type
(service-type (name 'pam)
(extensions (list (service-extension etc-service-type
/etc-entry)))
(compose concatenate)
(extend append)))
(define (pam-root-service base)
"The \"root\" PAM service, which collects <pam-service> instance and turns
them into a /etc/pam.d directory, including the <pam-service> listed in BASE."
(service pam-root-service-type base))
;;; linux.scm ends here ;;; linux.scm ends here

84
gnu/system/shadow.scm
View File

@ -22,12 +22,14 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix sets) #:use-module (guix sets)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (gnu services)
#:use-module ((gnu system file-systems) #:use-module ((gnu system file-systems)
#:select (%tty-gid)) #:select (%tty-gid))
#:use-module ((gnu packages admin) #:use-module ((gnu packages admin)
#:select (shadow)) #:select (shadow))
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages guile-wm) #:use-module (gnu packages guile-wm)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
@ -54,7 +56,9 @@
skeleton-directory skeleton-directory
%base-groups %base-groups
%base-user-accounts %base-user-accounts
assert-valid-users/groups))
account-service-type
account-service))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -87,6 +91,7 @@
(system? user-group-system? ; Boolean (system? user-group-system? ; Boolean
(default #f))) (default #f)))
(define %base-groups (define %base-groups
;; Default set of groups. ;; Default set of groups.
(let-syntax ((system-group (syntax-rules () (let-syntax ((system-group (syntax-rules ()
@ -224,4 +229,81 @@ of user '~a' is undeclared")
(user-account-supplementary-groups user))) (user-account-supplementary-groups user)))
users))) users)))
;;;
;;; Service.
;;;
(define (user-group->gexp group)
"Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
'active-groups'."
#~(list #$(user-group-name group)
#$(user-group-password group)
#$(user-group-id group)
#$(user-group-system? group)))
(define (user-account->gexp account)
"Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
'activate-users'."
#~`(#$(user-account-name account)
#$(user-account-uid account)
#$(user-account-group account)
#$(user-account-supplementary-groups account)
#$(user-account-comment account)
#$(user-account-home-directory account)
,#$(user-account-shell account) ; this one is a gexp
#$(user-account-password account)
#$(user-account-system? account)))
(define (account-activation accounts+groups)
"Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
<user-group> objects. Raise an error if a user account refers to a undefined
group."
(define accounts
(filter user-account? accounts+groups))
(define user-specs
(map user-account->gexp accounts))
(define groups
(filter user-group? accounts+groups))
(define group-specs
(map user-group->gexp groups))
(assert-valid-users/groups accounts groups)
;; Add users and user groups.
#~(begin
(setenv "PATH"
(string-append #$(@ (gnu packages admin) shadow) "/sbin"))
(activate-users+groups (list #$@user-specs)
(list #$@group-specs))))
(define (etc-skel arguments)
"Filter out among ARGUMENTS things corresponding to skeletons, and return
the /etc/skel directory for those."
(let ((skels (filter pair? arguments)))
`(("skel" ,(skeleton-directory skels)))))
(define account-service-type
(service-type (name 'account)
;; Concatenate <user-account>, <user-group>, and skeleton
;; lists.
(compose concatenate)
(extend append)
(extensions
(list (service-extension activation-service-type
account-activation)
(service-extension etc-service-type
etc-skel)))))
(define (account-service accounts+groups skeletons)
"Return a <service> that takes care of user accounts and user groups, with
ACCOUNTS+GROUPS as its initial list of accounts and groups."
(service account-service-type
(append skeletons accounts+groups)))
;;; shadow.scm ends here ;;; shadow.scm ends here

1
po/guix/POTFILES.in
View File

@ -1,6 +1,7 @@
# List of source files which contain translatable strings. # List of source files which contain translatable strings.
# This should be source files of the various tools, and not package modules. # This should be source files of the various tools, and not package modules.
gnu/packages.scm gnu/packages.scm
gnu/services.scm
gnu/system.scm gnu/system.scm
gnu/services/dmd.scm gnu/services/dmd.scm
gnu/system/shadow.scm gnu/system/shadow.scm

91
tests/services.scm Normal file
View File

@ -0,0 +1,91 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 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 (test-services)
#:use-module (gnu services)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64))
(test-begin "services")
(test-equal "fold-services"
;; Make sure 'fold-services' returns the right result. The numbers come
;; from services of type T3; 'xyz 60' comes from the service of type T2,
;; where 60 = 15 × 4 = (1 + 2 + 3 + 4 + 5) × 4.
'(initial-value 5 4 3 2 1 xyz 60)
(let* ((t1 (service-type (name 't1) (extensions '())
(compose concatenate)
(extend cons)))
(t2 (service-type (name 't2)
(extensions
(list (service-extension t1
(cut list 'xyz <>))))
(compose (cut reduce + 0 <>))
(extend *)))
(t3 (service-type (name 't3)
(extensions
(list (service-extension t2 identity)
(service-extension t1 list)))))
(r (fold-services (cons* (service t1 'initial-value)
(service t2 4)
(map (lambda (x)
(service t3 x))
(iota 5 1)))
#:target-type t1)))
(and (eq? (service-kind r) t1)
(service-parameters r))))
(test-assert "fold-services, ambiguity"
(let* ((t1 (service-type (name 't1) (extensions '())
(compose concatenate)
(extend cons)))
(t2 (service-type (name 't2)
(extensions
(list (service-extension t1 list)))))
(s (service t2 42)))
(guard (c ((ambiguous-target-service-error? c)
(and (eq? (ambiguous-target-service-error-target-type c)
t1)
(eq? (ambiguous-target-service-error-service c)
s))))
(fold-services (list (service t1 'first)
(service t1 'second)
s)
#:target-type t1)
#f)))
(test-assert "fold-services, missing target"
(let* ((t1 (service-type (name 't1) (extensions '())))
(t2 (service-type (name 't2)
(extensions
(list (service-extension t1 list)))))
(s (service t2 42)))
(guard (c ((missing-target-service-error? c)
(and (eq? (missing-target-service-error-target-type c)
t1)
(eq? (missing-target-service-error-service c)
s))))
(fold-services (list s) #:target-type t1)
#f)))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))