me/guix
Archived
1
0
Fork 0
Code Activity

system: Make service procedures non-monadic.

Browse source 
* gnu/services/avahi.scm (configuration-file): Use 'plain-file' instead
  of 'text-file'.
  (avahi-service): Turn into a regular procedure that returns a <service>.
* gnu/services/base.scm (root-file-system-service, file-system-service,
  user-unmount-service, user-processes-service, host-name-service,
  console-keymap-service, console-font-service, mingetty-service,
  nscd.conf-file, nscd-service): Likewise.
  (%default-syslog.conf): New variable.
  (syslog-service): Use it.  Turn into a regular procedure.
  (guix-service, udev-rules-union, kvm-udev-rule, udev-service,
  device-mapping-service, swap-service): Likewise.
* gnu/services/databases.scm (%default-postgres-hba,
  %default-postgres-ident): Use 'plain-file' instead of 'text-file'.
  (%default-postgres-config): Use 'mixed-text-file' instead of
  'text-file*'.
  (postgresql-service):  Use 'program-file' instead of 'gexp->script'.
  Turn into a regular procedure.
* gnu/services/desktop.scm (dbus-configuration-directory): Use
  'computed-file' instead of 'gexp->derivation'.
  (upower-configuration-file, geoclue-configuration-file,
  elogind-configuration-file): Use 'plain-file' instead of 'text-file'.
  (dbus-service, upower-service, colord-service, geoclue-service,
  polkit-service, elogind-service): Turn into regular procedures.
  (%desktop-services): Remove use of 'mlet' when iterating on
  %BASE-SERVICES.
* gnu/services/lirc.scm (lirc-service): Turn into a regular procedure.
* gnu/services/networking.scm (static-networking-service,
  dhcp-client-service, ntp-service, tor-service, bitlbee-service,
  wicd-service): Likewise.
* gnu/services/ssh.scm (lsh-service): Likewise.
* gnu/services/web.scm (nginx-service): Likewise.
* gnu/services/xorg.scm (xorg-configuration-file): Use 'mixed-text-file'
  instead of 'text-file*'.
  (xorg-start-command, slim-service): Turn into regular procedures.
  (xinitrc): Use 'program-file' instead of 'gexp->script'.
* gnu/system/install.scm (cow-store-service,
  configuration-template-service): Turn into regular procedures.
* gnu/system.scm (other-file-system-services, device-mapping-services,
  swap-services, essential-services, operating-system-services,
  user-shells, operating-system-accounts): Remove now unnecessary
  'mlet' and turn into regular procedures.
  (operating-system-etc-directory, operating-system-activation-script,
  operating-system-boot-script): Adjust accordingly.
* doc/guix.texi (Base Services, Networking Services, X Window, Desktop
  Services, Database Services, Web Services, Various Services, Name
  Service Switch): Adjust accordingly.
This commit is contained in:
Ludovic Courtès 2015-09-09 09:17:31 +02:00
parent ce8a6dfc43
commit be1c2c54d9
12 changed files with 1071 additions and 1153 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
doc/guix.texi
View file

@ -5749,11 +5749,11 @@ this:
@end example @end example
@end defvr @end defvr
@deffn {Monadic Procedure} host-name-service @var{name} @deffn {Scheme Procedure} host-name-service @var{name}
Return a service that sets the host name to @var{name}. Return a service that sets the host name to @var{name}.
@end deffn @end deffn
@deffn {Monadic Procedure} mingetty-service @var{tty} [#:motd] @ @deffn {Scheme Procedure} mingetty-service @var{tty} [#:motd] @
[#:auto-login #f] [#:login-program] [#:login-pause? #f] @ [#:auto-login #f] [#:login-program] [#:login-pause? #f] @
[#:allow-empty-passwords? #f] [#:allow-empty-passwords? #f]
Return a service to run mingetty on @var{tty}. Return a service to run mingetty on @var{tty}.
@ -5774,7 +5774,7 @@ the ``message of the day''.
@cindex name service cache daemon @cindex name service cache daemon
@cindex nscd @cindex nscd
@deffn {Monadic Procedure} nscd-service [@var{config}] [#:glibc glibc] @ @deffn {Scheme Procedure} nscd-service [@var{config}] [#:glibc glibc] @
[#:name-services '()] [#:name-services '()]
Return a service that runs libc's name service cache daemon (nscd) with Return a service that runs libc's name service cache daemon (nscd) with
the given @var{config}---an @code{<nscd-configuration>} object. the given @var{config}---an @code{<nscd-configuration>} object.
@ -5861,13 +5861,13 @@ external name servers do not even need to be queried.
@end defvr @end defvr
@deffn {Monadic Procedure} syslog-service [#:config-file #f] @deffn {Scheme Procedure} syslog-service [#:config-file #f]
Return a service that runs @code{syslogd}. If configuration file name Return a service that runs @code{syslogd}. If configuration file name
@var{config-file} is not specified, use some reasonable default @var{config-file} is not specified, use some reasonable default
settings. settings.
@end deffn @end deffn
@deffn {Monadic Procedure} guix-service [#:guix guix] @ @deffn {Scheme Procedure} guix-service [#:guix guix] @
[#:builder-group "guixbuild"] [#:build-accounts 10] @ [#:builder-group "guixbuild"] [#:build-accounts 10] @
[#:authorize-hydra-key? #t] [#:use-substitutes? #t] @ [#:authorize-hydra-key? #t] [#:use-substitutes? #t] @
[#:extra-options '()] [#:extra-options '()]
@ -5886,11 +5886,11 @@ Finally, @var{extra-options} is a list of additional command-line options
passed to @command{guix-daemon}. passed to @command{guix-daemon}.
@end deffn @end deffn
@deffn {Monadic Procedure} udev-service [#:udev udev] @deffn {Scheme Procedure} udev-service [#:udev udev]
Run @var{udev}, which populates the @file{/dev} directory dynamically. Run @var{udev}, which populates the @file{/dev} directory dynamically.
@end deffn @end deffn
@deffn {Monadic Procedure} console-keymap-service @var{file} @deffn {Scheme Procedure} console-keymap-service @var{file}
Return a service to load console keymap from @var{file} using Return a service to load console keymap from @var{file} using
@command{loadkeys} command. @command{loadkeys} command.
@end deffn @end deffn
@ -5903,12 +5903,12 @@ The @code{(gnu services networking)} module provides services to configure
the network interface. the network interface.
@cindex DHCP, networking service @cindex DHCP, networking service
@deffn {Monadic Procedure} dhcp-client-service [#:dhcp @var{isc-dhcp}] @deffn {Scheme Procedure} dhcp-client-service [#:dhcp @var{isc-dhcp}]
Return a service that runs @var{dhcp}, a Dynamic Host Configuration Return a service that runs @var{dhcp}, a Dynamic Host Configuration
Protocol (DHCP) client, on all the non-loopback network interfaces. Protocol (DHCP) client, on all the non-loopback network interfaces.
@end deffn @end deffn
@deffn {Monadic Procedure} static-networking-service @var{interface} @var{ip} @ @deffn {Scheme Procedure} static-networking-service @var{interface} @var{ip} @
[#:gateway #f] [#:name-services @code{'()}] [#:gateway #f] [#:name-services @code{'()}]
Return a service that starts @var{interface} with address @var{ip}. If 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 @var{gateway} is true, it must be a string specifying the default network
@ -5916,12 +5916,12 @@ gateway.
@end deffn @end deffn
@cindex wicd @cindex wicd
@deffn {Monadic Procedure} wicd-service [#:wicd @var{wicd}] @deffn {Scheme Procedure} wicd-service [#:wicd @var{wicd}]
Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a
network manager that aims to simplify wired and wireless networking. network manager that aims to simplify wired and wireless networking.
@end deffn @end deffn
@deffn {Monadic Procedure} ntp-service [#:ntp @var{ntp}] @ @deffn {Scheme Procedure} ntp-service [#:ntp @var{ntp}] @
[#:name-service @var{%ntp-servers}] [#:name-service @var{%ntp-servers}]
Return a service that runs the daemon from @var{ntp}, the Return a service that runs the daemon from @var{ntp}, the
@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will @uref{http://www.ntp.org, Network Time Protocol package}. The daemon will
@ -5932,14 +5932,14 @@ keep the system clock synchronized with that of @var{servers}.
List of host names used as the default NTP servers. List of host names used as the default NTP servers.
@end defvr @end defvr
@deffn {Monadic Procedure} tor-service [#:tor tor] @deffn {Scheme Procedure} tor-service [#:tor tor]
Return a service to run the @uref{https://torproject.org,Tor} daemon. Return a service to run the @uref{https://torproject.org,Tor} daemon.
The daemon runs with the default settings (in particular the default exit The daemon runs with the default settings (in particular the default exit
policy) as the @code{tor} unprivileged user. policy) as the @code{tor} unprivileged user.
@end deffn @end deffn
@deffn {Monadic Procedure} bitlbee-service [#:bitlbee bitlbee] @ @deffn {Scheme Procedure} bitlbee-service [#:bitlbee bitlbee] @
[#:interface "127.0.0.1"] [#:port 6667] @ [#:interface "127.0.0.1"] [#:port 6667] @
[#:extra-settings ""] [#:extra-settings ""]
Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that
@ -5956,7 +5956,7 @@ configuration file.
Furthermore, @code{(gnu services ssh)} provides the following service. Furthermore, @code{(gnu services ssh)} provides the following service.
@deffn {Monadic Procedure} lsh-service [#:host-key "/etc/lsh/host-key"] @ @deffn {Scheme Procedure} lsh-service [#:host-key "/etc/lsh/host-key"] @
[#:daemonic? #t] [#:interfaces '()] [#:port-number 22] @ [#:daemonic? #t] [#:interfaces '()] [#:port-number 22] @
[#:allow-empty-passwords? #f] [#:root-login? #f] @ [#:allow-empty-passwords? #f] [#:root-login? #f] @
[#:syslog-output? #t] [#:x11-forwarding? #t] @ [#:syslog-output? #t] [#:x11-forwarding? #t] @
@ -6023,7 +6023,7 @@ browsers, from accessing Facebook.
The @code{(gnu services avahi)} provides the following definition. The @code{(gnu services avahi)} provides the following definition.
@deffn {Monadic Procedure} avahi-service [#:avahi @var{avahi}] @ @deffn {Scheme Procedure} avahi-service [#:avahi @var{avahi}] @
[#:host-name #f] [#:publish? #t] [#:ipv4? #t] @ [#:host-name #f] [#:publish? #t] [#:ipv4? #t] @
[#:ipv6? #t] [#:wide-area? #f] @ [#:ipv6? #t] [#:wide-area? #f] @
[#:domains-to-browse '()] [#:domains-to-browse '()]
@ -6053,7 +6053,7 @@ Xorg---is provided by the @code{(gnu services xorg)} module. Note that
there is no @code{xorg-service} procedure. Instead, the X server is there is no @code{xorg-service} procedure. Instead, the X server is
started by the @dfn{login manager}, currently SLiM. started by the @dfn{login manager}, currently SLiM.
@deffn {Monadic Procedure} slim-service [#:allow-empty-passwords? #f] @ @deffn {Scheme Procedure} slim-service [#:allow-empty-passwords? #f] @
[#:auto-login? #f] [#:default-user ""] [#:startx] @ [#:auto-login? #f] [#:default-user ""] [#:startx] @
[#:theme @var{%default-slim-theme}] @ [#:theme @var{%default-slim-theme}] @
[#:theme-name @var{%default-slim-theme-name}] [#:theme-name @var{%default-slim-theme-name}]
@ -6089,7 +6089,7 @@ theme.
The G-Expression denoting the default SLiM theme and its name. The G-Expression denoting the default SLiM theme and its name.
@end defvr @end defvr
@deffn {Monadic Procedure} xorg-start-command [#:guile] @ @deffn {Scheme Procedure} xorg-start-command [#:guile] @
[#:configuration-file #f] [#:xorg-server @var{xorg-server}] [#:configuration-file #f] [#:xorg-server @var{xorg-server}]
Return a derivation that builds a @var{guile} script to start the X server Return a derivation that builds a @var{guile} script to start the X server
from @var{xorg-server}. @var{configuration-file} is the server configuration from @var{xorg-server}. @var{configuration-file} is the server configuration
@ -6099,7 +6099,7 @@ file or a derivation that builds it; when omitted, the result of
Usually the X server is started by a login manager. Usually the X server is started by a login manager.
@end deffn @end deffn
@deffn {Monadic Procedure} xorg-configuration-file @ @deffn {Scheme Procedure} xorg-configuration-file @
[#:drivers '()] [#:resolutions '()] [#:extra-config '()] [#:drivers '()] [#:resolutions '()] [#:extra-config '()]
Return a configuration file for the Xorg server containing search paths for Return a configuration file for the Xorg server containing search paths for
all the common drivers. all the common drivers.
@ -6150,7 +6150,7 @@ Reference, @code{services}}).
The actual service definitions provided by @code{(gnu services desktop)} The actual service definitions provided by @code{(gnu services desktop)}
are described below. are described below.
@deffn {Monadic Procedure} dbus-service @var{services} @ @deffn {Scheme Procedure} dbus-service @var{services} @
[#:dbus @var{dbus}] [#: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}.
@ -6165,7 +6165,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 {Monadic Procedure} elogind-service @ @deffn {Scheme Procedure} elogind-service @
[#:elogind @var{elogind}] [#: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,
@ -6236,7 +6236,7 @@ their default values are:
@end table @end table
@end deffn @end deffn
@deffn {Monadic Procedure} polkit-service @ @deffn {Scheme Procedure} polkit-service @
[#:polkit @var{polkit}] [#:polkit @var{polkit}]
Return a service that runs the Polkit privilege manager. Return a service that runs the Polkit privilege manager.
@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit} allows @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit} allows
@ -6246,7 +6246,7 @@ whose session is active to shut down the machine, if there are no other
users active. users active.
@end deffn @end deffn
@deffn {Monadic Procedure} upower-service [#:upower @var{upower}] @ @deffn {Scheme Procedure} upower-service [#:upower @var{upower}] @
[#:watts-up-pro? #f] @ [#:watts-up-pro? #f] @
[#:poll-batteries? #t] @ [#:poll-batteries? #t] @
[#:ignore-lid? #f] @ [#:ignore-lid? #f] @
@ -6265,7 +6265,7 @@ levels, with the given configuration settings. It implements the
GNOME. GNOME.
@end deffn @end deffn
@deffn {Monadic Procedure} colord-service [#:colord @var{colord}] @deffn {Scheme Procedure} colord-service [#:colord @var{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
@ -6293,7 +6293,7 @@ Firefox and Epiphany both query the user before allowing a web page to
know the user's location. know the user's location.
@end defvr @end defvr
@deffn {Monadic Procedure} geoclue-service [#:colord @var{colord}] @ @deffn {Scheme Procedure} geoclue-service [#:colord @var{colord}] @
[#:whitelist '()] @ [#:whitelist '()] @
[#:wifi-geolocation-url "https://location.services.mozilla.com/v1/geolocate?key=geoclue"] @ [#:wifi-geolocation-url "https://location.services.mozilla.com/v1/geolocate?key=geoclue"] @
[#:submit-data? #f] [#:submit-data? #f]
@ -6313,7 +6313,7 @@ web site} for more information.
The @code{(gnu services databases)} module provides the following service. The @code{(gnu services databases)} module provides the following service.
@deffn {Monadic Procedure} postgresql-service [#:postgresql postgresql] @ @deffn {Scheme Procedure} postgresql-service [#:postgresql postgresql] @
[#:config-file] [#:data-directory ``/var/lib/postgresql/data''] [#:config-file] [#:data-directory ``/var/lib/postgresql/data'']
Return a service that runs @var{postgresql}, the PostgreSQL database Return a service that runs @var{postgresql}, the PostgreSQL database
server. server.
@ -6328,7 +6328,7 @@ The PostgreSQL daemon loads its runtime configuration from
The @code{(gnu services web)} module provides the following service: The @code{(gnu services web)} module provides the following service:
@deffn {Monadic Procedure} nginx-service [#:nginx nginx] @ @deffn {Scheme Procedure} nginx-service [#:nginx nginx] @
[#:log-directory ``/var/log/nginx''] @ [#:log-directory ``/var/log/nginx''] @
[#:run-directory ``/var/run/nginx''] @ [#:run-directory ``/var/run/nginx''] @
[#:config-file] [#:config-file]
@ -6348,7 +6348,7 @@ directories are created when the service is activated.
The @code{(gnu services lirc)} module provides the following service. The @code{(gnu services lirc)} module provides the following service.
@deffn {Monadic Procedure} lirc-service [#:lirc lirc] @ @deffn {Scheme Procedure} lirc-service [#:lirc lirc] @
[#:device #f] [#:driver #f] [#:config-file #f] @ [#:device #f] [#:driver #f] [#:config-file #f] @
[#:extra-options '()] [#:extra-options '()]
Return a service that runs @url{http://www.lirc.org,LIRC}, a daemon that Return a service that runs @url{http://www.lirc.org,LIRC}, a daemon that
@ -6521,13 +6521,11 @@ configuration file:
(define %my-base-services (define %my-base-services
;; Replace the default nscd service with one that knows ;; Replace the default nscd service with one that knows
;; about nss-mdns. ;; about nss-mdns.
(map (lambda (mservice) (map (lambda (service)
;; "Bind" the MSERVICE monadic value to inspect it. (if (member 'nscd (service-provision service))
(mlet %store-monad ((service mservice)) (nscd-service (nscd-configuration)
(if (member 'nscd (service-provision service)) #:name-services (list nss-mdns))
(nscd-service (nscd-configuration) service))
#:name-services (list nss-mdns))
mservice)))
%base-services)) %base-services))
@end example @end example

88
gnu/services/avahi.scm
View file

@ -21,7 +21,6 @@
#: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 monads)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
#:export (avahi-service)) #:export (avahi-service))
@ -39,21 +38,21 @@
(define (bool value) (define (bool value)
(if value "yes\n" "no\n")) (if value "yes\n" "no\n"))
(text-file "avahi-daemon.conf" (plain-file "avahi-daemon.conf"
(string-append (string-append
"[server]\n" "[server]\n"
(if host-name (if host-name
(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 domains-to-browse)
"\n" "\n"
"use-ipv4=" (bool ipv4?) "use-ipv4=" (bool ipv4?)
"use-ipv6=" (bool ipv6?) "use-ipv6=" (bool ipv6?)
"[wide-area]\n" "[wide-area]\n"
"enable-wide-area=" (bool wide-area?) "enable-wide-area=" (bool wide-area?)
"[publish]\n" "[publish]\n"
"disable-publishing=" (bool (not publish?))))) "disable-publishing=" (bool (not publish?)))))
(define* (avahi-service #:key (avahi avahi) (define* (avahi-service #:key (avahi avahi)
host-name host-name
@ -76,37 +75,36 @@ 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."
(mlet %store-monad ((config (configuration-file #:host-name host-name (let ((config (configuration-file #:host-name host-name
#:publish? publish? #:publish? publish?
#:ipv4? ipv4? #:ipv4? ipv4?
#:ipv6? ipv6? #:ipv6? ipv6?
#:wide-area? wide-area? #:wide-area? wide-area?
#:domains-to-browse #:domains-to-browse
domains-to-browse))) domains-to-browse)))
(return (service
(service (documentation "Run the Avahi mDNS/DNS-SD responder.")
(documentation "Run the Avahi mDNS/DNS-SD responder.") (provision '(avahi-daemon))
(provision '(avahi-daemon)) (requirement '(dbus-system networking))
(requirement '(dbus-system networking))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$avahi "/sbin/avahi-daemon") (list (string-append #$avahi "/sbin/avahi-daemon")
"--syslog" "-f" #$config))) "--syslog" "-f" #$config)))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(activate #~(begin (activate #~(begin
(use-modules (guix build utils)) (use-modules (guix build utils))
(mkdir-p "/var/run/avahi-daemon"))) (mkdir-p "/var/run/avahi-daemon")))
(user-groups (list (user-group (user-groups (list (user-group
(name "avahi") (name "avahi")
(system? #t)))) (system? #t))))
(user-accounts (list (user-account (user-accounts (list (user-account
(name "avahi") (name "avahi")
(group "avahi") (group "avahi")
(system? #t) (system? #t)
(comment "Avahi daemon user") (comment "Avahi daemon user")
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (shell
#~(string-append #$shadow "/sbin/nologin"))))))))) #~(string-append #$shadow "/sbin/nologin"))))))))
;;; avahi.scm ends here ;;; avahi.scm ends here

822
gnu/services/base.scm
View file

@ -35,7 +35,6 @@
#:use-module ((gnu build file-systems) #:use-module ((gnu build file-systems)
#:select (mount-flags->bit-mask)) #:select (mount-flags->bit-mask))
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix records) #:use-module (guix records)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -80,41 +79,39 @@ system upon shutdown (aka. cleanly \"umounting\" root.)
This service must be the root of the service dependency graph so that its This service must be the root of the service dependency graph so that its
'stop' action is invoked when dmd is the only process left." 'stop' action is invoked when dmd is the only process left."
(with-monad %store-monad (service
(return (documentation "Take care of the root file system.")
(service (provision '(root-file-system))
(documentation "Take care of the root file system.") (start #~(const #t))
(provision '(root-file-system)) (stop #~(lambda _
(start #~(const #t)) ;; Return #f if successfully stopped.
(stop #~(lambda _ (sync)
;; Return #f if successfully stopped.
(sync)
(call-with-blocked-asyncs (call-with-blocked-asyncs
(lambda () (lambda ()
(let ((null (%make-void-port "w"))) (let ((null (%make-void-port "w")))
;; Close 'dmd.log'. ;; Close 'dmd.log'.
(display "closing log\n") (display "closing log\n")
;; XXX: Ideally we'd use 'stop-logging', but that one ;; XXX: Ideally we'd use 'stop-logging', but that one
;; doesn't actually close the port as of dmd 0.1. ;; doesn't actually close the port as of dmd 0.1.
(close-port (@@ (dmd comm) log-output-port)) (close-port (@@ (dmd comm) log-output-port))
(set! (@@ (dmd comm) log-output-port) null) (set! (@@ (dmd comm) log-output-port) null)
;; Redirect the default output ports.. ;; Redirect the default output ports..
(set-current-output-port null) (set-current-output-port null)
(set-current-error-port null) (set-current-error-port null)
;; Close /dev/console. ;; Close /dev/console.
(for-each close-fdes '(0 1 2)) (for-each close-fdes '(0 1 2))
;; At this point, there are no open files left, so the ;; At this point, there are no open files left, so the
;; root file system can be re-mounted read-only. ;; root file system can be re-mounted read-only.
(mount #f "/" #f (mount #f "/" #f
(logior MS_REMOUNT MS_RDONLY) (logior MS_REMOUNT MS_RDONLY)
#:update-mtab? #f) #:update-mtab? #f)
#f))))) #f)))))
(respawn? #f))))) (respawn? #f)))
(define* (file-system-service device target type (define* (file-system-service device target type
#:key (flags '()) (check? #t) #:key (flags '()) (check? #t)
@ -127,79 +124,75 @@ true, check the file system before mounting it. When CREATE-MOUNT-POINT? is
true, create TARGET if it does not exist yet. FLAGS is a list of symbols, true, create TARGET if it does not exist yet. FLAGS is a list of symbols,
such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service
names such as device-mapping services." names such as device-mapping services."
(with-monad %store-monad (service
(return (provision (list (symbol-append 'file-system- (string->symbol target))))
(service (requirement `(root-file-system ,@requirements))
(provision (list (symbol-append 'file-system- (string->symbol target)))) (documentation "Check, mount, and unmount the given file system.")
(requirement `(root-file-system ,@requirements)) (start #~(lambda args
(documentation "Check, mount, and unmount the given file system.") ;; FIXME: Use or factorize with 'mount-file-system'.
(start #~(lambda args (let ((device (canonicalize-device-spec #$device '#$title))
;; FIXME: Use or factorize with 'mount-file-system'. (flags #$(mount-flags->bit-mask flags)))
(let ((device (canonicalize-device-spec #$device '#$title)) #$(if create-mount-point?
(flags #$(mount-flags->bit-mask flags))) #~(mkdir-p #$target)
#$(if create-mount-point? #~#t)
#~(mkdir-p #$target) #$(if check?
#~#t) #~(begin
#$(if check? ;; Make sure fsck.ext2 & co. can be found.
#~(begin (setenv "PATH"
;; Make sure fsck.ext2 & co. can be found. (string-append
(setenv "PATH" #$e2fsprogs "/sbin:"
(string-append "/run/current-system/profile/sbin:"
#$e2fsprogs "/sbin:" (getenv "PATH")))
"/run/current-system/profile/sbin:" (check-file-system device #$type))
(getenv "PATH"))) #~#t)
(check-file-system device #$type))
#~#t)
(mount device #$target #$type flags #$options) (mount device #$target #$type flags #$options)
;; 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
;; applies to Linux 4.0. ;; applies to Linux 4.0.
(when (and (= MS_BIND (logand flags MS_BIND)) (when (and (= MS_BIND (logand flags MS_BIND))
(= MS_RDONLY (logand flags MS_RDONLY))) (= MS_RDONLY (logand flags MS_RDONLY)))
(mount device #$target #$type (mount device #$target #$type
(logior MS_BIND MS_REMOUNT MS_RDONLY)))) (logior MS_BIND MS_REMOUNT MS_RDONLY))))
#t)) #t))
(stop #~(lambda args (stop #~(lambda args
;; Normally there are no processes left at this point, so ;; Normally there are no processes left at this point, so
;; TARGET can be safely unmounted. ;; TARGET can be safely unmounted.
;; Make sure PID 1 doesn't keep TARGET busy. ;; Make sure PID 1 doesn't keep TARGET busy.
(chdir "/") (chdir "/")
(umount #$target) (umount #$target)
#f)))))) #f))))
(define (user-unmount-service known-mount-points) (define (user-unmount-service known-mount-points)
"Return a service whose sole purpose is to unmount file systems not listed "Return a service whose sole purpose is to unmount file systems not listed
in KNOWN-MOUNT-POINTS when it is stopped." in KNOWN-MOUNT-POINTS when it is stopped."
(with-monad %store-monad (service
(return (documentation "Unmount manually-mounted file systems.")
(service (provision '(user-unmount))
(documentation "Unmount manually-mounted file systems.") (start #~(const #t))
(provision '(user-unmount)) (stop #~(lambda args
(start #~(const #t)) (define (known? mount-point)
(stop #~(lambda args (member mount-point
(define (known? mount-point) (cons* "/proc" "/sys"
(member mount-point '#$known-mount-points)))
(cons* "/proc" "/sys"
'#$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 "/")
(for-each (lambda (mount-point) (for-each (lambda (mount-point)
(format #t "unmounting '~a'...~%" mount-point) (format #t "unmounting '~a'...~%" mount-point)
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(umount mount-point)) (umount mount-point))
(lambda args (lambda args
(let ((errno (system-error-errno args))) (let ((errno (system-error-errno args)))
(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 %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
@ -217,86 +210,84 @@ listed in REQUIREMENTS.
All the services that spawn processes must depend on this one so that they are All the services that spawn processes must depend on this one so that they are
stopped before 'kill' is called." stopped before 'kill' is called."
(with-monad %store-monad (service
(return (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 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 in OMIT and the current process.
;; listed 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) (false-if-exception
(false-if-exception (kill pid signal))))
(kill pid signal)))) (processes))))
(processes))))
(define omitted-pids (define omitted-pids
;; List of PIDs that must not be killed. ;; List of PIDs that must not be killed.
(if (file-exists? #$%do-not-kill-file) (if (file-exists? #$%do-not-kill-file)
(map string->number (map string->number
(call-with-input-file #$%do-not-kill-file (call-with-input-file #$%do-not-kill-file
(compose string-tokenize (compose string-tokenize
(@ (ice-9 rdelim) read-string)))) (@ (ice-9 rdelim) read-string))))
'())) '()))
(define (now) (define (now)
(car (gettimeofday))) (car (gettimeofday)))
(define (sleep* n) (define (sleep* n)
;; Really sleep N seconds. ;; Really sleep N seconds.
;; Work around <http://bugs.gnu.org/19581>. ;; Work around <http://bugs.gnu.org/19581>.
(define start (now)) (define start (now))
(let loop ((elapsed 0)) (let loop ((elapsed 0))
(when (> n elapsed) (when (> n elapsed)
(sleep (- n elapsed)) (sleep (- n elapsed))
(loop (- (now) start))))) (loop (- (now) start)))))
(define lset= (@ (srfi srfi-1) lset=)) (define lset= (@ (srfi srfi-1) lset=))
(display "sending all processes the TERM signal\n") (display "sending all processes the TERM signal\n")
(if (null? omitted-pids) (if (null? omitted-pids)
(begin (begin
;; Easy: terminate all of them. ;; Easy: terminate all of them.
(kill -1 SIGTERM) (kill -1 SIGTERM)
(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 like to (kill -1 SIGSTOP) to get a fixed ;; would like to (kill -1 SIGSTOP) to get a fixed
;; list of processes, like 'killall5' does, but ;; list of processes, like 'killall5' does, but
;; that seems unreliable. ;; that seems 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)
(delete-file #$%do-not-kill-file))) (delete-file #$%do-not-kill-file)))
(let wait () (let wait ()
(let ((pids (processes))) (let ((pids (processes)))
(unless (lset= = pids (cons 1 omitted-pids)) (unless (lset= = pids (cons 1 omitted-pids))
(format #t "waiting for process termination\ (format #t "waiting for process termination\
(processes left: ~s)~%" (processes left: ~s)~%"
pids) pids)
(sleep* 2) (sleep* 2)
(wait)))) (wait))))
(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 (host-name-service name)
"Return a service that sets the host name to @var{name}." "Return a service that sets the host name to @var{name}."
(with-monad %store-monad (service
(return (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 (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}."
@ -318,16 +309,13 @@ stopped before 'kill' is called."
(define (console-keymap-service file) (define (console-keymap-service file)
"Return a service to load console keymap from @var{file}." "Return a service to load console keymap from @var{file}."
(with-monad %store-monad (service
(return (documentation (string-append "Load console keymap (loadkeys)."))
(service (provision '(console-keymap))
(documentation (start #~(lambda _
(string-append "Load console keymap (loadkeys).")) (zero? (system* (string-append #$kbd "/bin/loadkeys")
(provision '(console-keymap)) #$file))))
(start #~(lambda _ (respawn? #f)))
(zero? (system* (string-append #$kbd "/bin/loadkeys")
#$file))))
(respawn? #f)))))
(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16")) (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
"Return a service that sets up Unicode support in @var{tty} and loads "Return a service that sets up Unicode support in @var{tty} and loads
@ -336,24 +324,23 @@ stopped before 'kill' is called."
;; scripts as well as glyphs for em dash, quotation marks, and other Unicode ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
;; codepoints notably found in the UTF-8 manual. ;; codepoints notably found in the UTF-8 manual.
(let ((device (string-append "/dev/" tty))) (let ((device (string-append "/dev/" tty)))
(with-monad %store-monad (service
(return (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 are ignored. ;; settings are ignored.
(requirement (list (symbol-append 'term- (requirement (list (symbol-append 'term-
(string->symbol tty)))) (string->symbol tty))))
(start #~(lambda _ (start #~(lambda _
(and #$(unicode-start device) (and #$(unicode-start device)
(zero? (zero?
(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* (mingetty-service tty (define* (mingetty-service tty
#:key #:key
@ -379,38 +366,36 @@ of the log-in program (the default is the @code{login} program from the Shadow
tool suite.) tool suite.)
@var{motd} is a file-like object to use as the ``message of the day''." @var{motd} is a file-like object to use as the ``message of the day''."
(with-monad %store-monad (service
(return (documentation (string-append "Run mingetty on " tty "."))
(service (provision (list (symbol-append 'term- (string->symbol tty))))
(documentation (string-append "Run mingetty on " tty "."))
(provision (list (symbol-append 'term- (string->symbol tty))))
;; Since the login prompt shows the host name, wait for the 'host-name' ;; Since the login prompt shows the host name, wait for the 'host-name'
;; service to be done. Also wait for udev essentially so that the tty ;; service to be done. Also wait for udev essentially so that the tty
;; text is not lost in the middle of kernel messages (XXX). ;; text is not lost in the middle of kernel messages (XXX).
(requirement '(user-processes host-name udev)) (requirement '(user-processes host-name udev))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$mingetty "/sbin/mingetty") (list (string-append #$mingetty "/sbin/mingetty")
"--noclear" #$tty "--noclear" #$tty
#$@(if auto-login #$@(if auto-login
#~("--autologin" #$auto-login) #~("--autologin" #$auto-login)
#~()) #~())
#$@(if login-program #$@(if login-program
#~("--loginprog" #$login-program) #~("--loginprog" #$login-program)
#~()) #~())
#$@(if login-pause? #$@(if login-pause?
#~("--loginpause") #~("--loginpause")
#~())))) #~()))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(pam-services (pam-services
;; Let 'login' be known to PAM. All the mingetty services will have ;; Let 'login' be known to PAM. All the mingetty services will have
;; that PAM service, but that's fine because they're all identical and ;; that PAM service, but that's fine because they're all identical and
;; duplicates are removed. ;; duplicates are removed.
(list (unix-pam-service "login" (list (unix-pam-service "login"
#:allow-empty-passwords? allow-empty-passwords? #:allow-empty-passwords? allow-empty-passwords?
#:motd motd))))))) #:motd motd)))))
(define-record-type* <nscd-configuration> nscd-configuration (define-record-type* <nscd-configuration> nscd-configuration
make-nscd-configuration make-nscd-configuration
@ -472,44 +457,44 @@ tool suite.)
@code{<nscd-configuration>} object." @code{<nscd-configuration>} object."
(define cache->config (define cache->config
(match-lambda (match-lambda
(($ <nscd-cache> (= symbol->string database) (($ <nscd-cache> (= symbol->string database)
positive-ttl negative-ttl size check-files? positive-ttl negative-ttl size check-files?
persistent? shared? max-size propagate?) persistent? shared? max-size propagate?)
(string-append "\nenable-cache\t" database "\tyes\n" (string-append "\nenable-cache\t" database "\tyes\n"
"positive-time-to-live\t" database "\t" "positive-time-to-live\t" database "\t"
(number->string positive-ttl) "\n" (number->string positive-ttl) "\n"
"negative-time-to-live\t" database "\t" "negative-time-to-live\t" database "\t"
(number->string negative-ttl) "\n" (number->string negative-ttl) "\n"
"suggested-size\t" database "\t" "suggested-size\t" database "\t"
(number->string size) "\n" (number->string size) "\n"
"check-files\t" database "\t" "check-files\t" database "\t"
(if check-files? "yes\n" "no\n") (if check-files? "yes\n" "no\n")
"persistent\t" database "\t" "persistent\t" database "\t"
(if persistent? "yes\n" "no\n") (if persistent? "yes\n" "no\n")
"shared\t" database "\t" "shared\t" database "\t"
(if shared? "yes\n" "no\n") (if shared? "yes\n" "no\n")
"max-db-size\t" database "\t" "max-db-size\t" database "\t"
(number->string max-size) "\n" (number->string max-size) "\n"
"auto-propagate\t" database "\t" "auto-propagate\t" database "\t"
(if propagate? "yes\n" "no\n"))))) (if propagate? "yes\n" "no\n")))))
(match config (match config
(($ <nscd-configuration> log-file debug-level caches) (($ <nscd-configuration> log-file debug-level caches)
(text-file "nscd.conf" (plain-file "nscd.conf"
(string-append "\ (string-append "\
# Configuration of libc's name service cache daemon (nscd).\n\n" # Configuration of libc's name service cache daemon (nscd).\n\n"
(if log-file (if log-file
(string-append "logfile\t" log-file) (string-append "logfile\t" log-file)
"") "")
"\n" "\n"
(if debug-level (if debug-level
(string-append "debug-level\t" (string-append "debug-level\t"
(number->string debug-level)) (number->string debug-level))
"") "")
"\n" "\n"
(string-concatenate (string-concatenate
(map cache->config caches))))))) (map cache->config caches)))))))
(define* (nscd-service #:optional (config %nscd-default-configuration) (define* (nscd-service #:optional (config %nscd-default-configuration)
#:key (glibc (canonical-package glibc)) #:key (glibc (canonical-package glibc))
@ -518,39 +503,35 @@ tool suite.)
given @var{config}---an @code{<nscd-configuration>} object. Optionally, given @var{config}---an @code{<nscd-configuration>} object. Optionally,
@code{#:name-services} is a list of packages that provide name service switch @code{#:name-services} is a list of packages that provide name service switch
(NSS) modules needed by nscd. @xref{Name Service Switch}, for an example." (NSS) modules needed by nscd. @xref{Name Service Switch}, for an example."
(mlet %store-monad ((nscd.conf (nscd.conf-file config))) (let ((nscd.conf (nscd.conf-file config)))
(return (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 (activate #~(begin
(use-modules (guix build utils)) (use-modules (guix build utils))
(mkdir-p "/var/run/nscd") (mkdir-p "/var/run/nscd")
(mkdir-p "/var/db/nscd"))) ;for the persistent cache (mkdir-p "/var/db/nscd"))) ;for the persistent cache
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$glibc "/sbin/nscd") (list (string-append #$glibc "/sbin/nscd")
"-f" #$nscd.conf "--foreground") "-f" #$nscd.conf "--foreground")
#:environment-variables #:environment-variables
(list (string-append "LD_LIBRARY_PATH=" (list (string-append "LD_LIBRARY_PATH="
(string-join (string-join
(map (lambda (dir) (map (lambda (dir)
(string-append dir "/lib")) (string-append dir "/lib"))
(list #$@name-services)) (list #$@name-services))
":"))))) ":")))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(respawn? #f))))) (respawn? #f))))
(define* (syslog-service #:key config-file) ;; Snippet adapted from the GNU inetutils manual.
"Return a service that runs @code{syslogd}. (define %default-syslog.conf
If configuration file name @var{config-file} is not specified, use some (plain-file "syslog.conf" "
reasonable default settings."
;; Snippet adapted from the GNU inetutils manual.
(define contents "
# Log all error messages, authentication messages of # Log all error messages, authentication messages of
# level notice or higher and anything of level err or # level notice or higher and anything of level err or
# higher to the console. # higher to the console.
@ -569,20 +550,19 @@ reasonable default settings."
# 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))
(mlet %store-monad "Return a service that runs @code{syslogd}.
((syslog.conf (text-file "syslog.conf" contents))) If configuration file name @var{config-file} is not specified, use some
(return reasonable default settings."
(service (service
(documentation "Run the syslog daemon (syslogd).") (documentation "Run the syslog daemon (syslogd).")
(provision '(syslogd)) (provision '(syslogd))
(requirement '(user-processes)) (requirement '(user-processes))
(start (start #~(make-forkexec-constructor
#~(make-forkexec-constructor (list (string-append #$inetutils "/libexec/syslogd")
(list (string-append #$inetutils "/libexec/syslogd") "--no-detach" "--rcfile" #$config-file)))
"--no-detach" "--rcfile" #$(or config-file syslog.conf)))) (stop #~(make-kill-destructor))))
(stop #~(make-kill-destructor))))))
(define* (guix-build-accounts count #:key (define* (guix-build-accounts count #:key
(group "guixbuild") (group "guixbuild")
@ -658,36 +638,34 @@ passed to @command{guix-daemon}."
(and authorize-hydra-key? (and authorize-hydra-key?
(hydra-key-authorization guix))) (hydra-key-authorization guix)))
(with-monad %store-monad (service
(return (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" #$builder-group #$@(if use-substitutes?
#$@(if use-substitutes? '()
'() '("--no-substitutes"))
'("--no-substitutes")) #$@extra-options)
#$@extra-options)
;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
;; daemon's $PATH. ;; daemon's $PATH.
#:environment-variables #:environment-variables
(list (string-append "PATH=" #$lsof "/bin:" (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
#$lsh "/bin")))) (stop #~(make-kill-destructor))
(stop #~(make-kill-destructor)) (user-accounts (guix-build-accounts build-accounts
(user-accounts (guix-build-accounts build-accounts #:group builder-group))
#:group builder-group)) (user-groups (list (user-group
(user-groups (list (user-group (name builder-group)
(name builder-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 owner. ;; store with the right owner.
(id 30000)))) (id 30000))))
(activate activate))))) (activate activate)))
(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
@ -712,124 +690,125 @@ item of @var{packages}."
(union-build (string-append #$output "/lib/udev/rules.d") (union-build (string-append #$output "/lib/udev/rules.d")
(filter-map rules-sub-directory '#$packages)))) (filter-map rules-sub-directory '#$packages))))
(gexp->derivation "udev-rules" build (computed-file "udev-rules" build
#:modules '((guix build union) #:modules '((guix build union)
(guix build utils)) (guix build utils))))
#:local-build? #t))
(define* (kvm-udev-rule) (define* (kvm-udev-rule)
"Return a directory with a udev rule that changes the group of "Return a directory with a udev rule that changes the group of
@file{/dev/kvm} to \"kvm\" and makes it #o660." @file{/dev/kvm} to \"kvm\" and makes it #o660."
;; Apparently QEMU-KVM used to ship this rule, but now we have to add it by ;; Apparently QEMU-KVM used to ship this rule, but now we have to add it by
;; ourselves. ;; ourselves.
(gexp->derivation "kvm-udev-rules" (computed-file "kvm-udev-rules"
#~(begin #~(begin
(use-modules (guix build utils)) (use-modules (guix build utils))
(define rules.d (define rules.d
(string-append #$output "/lib/udev/rules.d")) (string-append #$output "/lib/udev/rules.d"))
(mkdir-p rules.d) (mkdir-p rules.d)
(call-with-output-file (call-with-output-file
(string-append rules.d "/90-kvm.rules") (string-append rules.d "/90-kvm.rules")
(lambda (port) (lambda (port)
;; Build users are part of the "kvm" group, so we ;; Build users are part of the "kvm" group, so we
;; can fearlessly make /dev/kvm 660 (see ;; can fearlessly make /dev/kvm 660 (see
;; <http://bugs.gnu.org/18994>, for background.) ;; <http://bugs.gnu.org/18994>, for background.)
(display "\ (display "\
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-service #:key (udev eudev) (rules '()))
"Run @var{udev}, which populates the @file{/dev} directory dynamically. Get "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
extra rules from the packages listed in @var{rules}." extra rules from the packages listed in @var{rules}."
(mlet* %store-monad ((kvm (kvm-udev-rule)) (let* ((rules (udev-rules-union (cons* udev
(rules (udev-rules-union (cons* udev kvm rules))) (kvm-udev-rule)
(udev.conf (text-file* "udev.conf" rules)))
"udev_rules=\"" rules (udev.conf (computed-file "udev.conf"
"/lib/udev/rules.d\"\n"))) #~(call-with-output-file #$output
(return (service (lambda (port)
(provision '(udev)) (format port
"udev_rules=\"~a/lib/udev/rules.d\"\n"
#$rules))))))
(service
(provision '(udev))
;; Udev needs /dev to be a 'devtmpfs' mount so that new device ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
;; nodes can be added: see ;; be added: see
;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>. ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
(requirement '(root-file-system)) (requirement '(root-file-system))
(documentation "Populate the /dev directory, dynamically.") (documentation "Populate the /dev directory, dynamically.")
(start #~(lambda () (start #~(lambda ()
(define find (define find
(@ (srfi srfi-1) find)) (@ (srfi srfi-1) find))
(define udevd (define udevd
;; Choose the right 'udevd'. ;; Choose the right 'udevd'.
(find file-exists? (find file-exists?
(map (lambda (suffix) (map (lambda (suffix)
(string-append #$udev suffix)) (string-append #$udev suffix))
'("/libexec/udev/udevd" ;udev '("/libexec/udev/udevd" ;udev
"/sbin/udevd")))) ;eudev "/sbin/udevd")))) ;eudev
(define (wait-for-udevd) (define (wait-for-udevd)
;; Wait until someone's listening on udevd's control ;; Wait until someone's listening on udevd's control
;; socket. ;; socket.
(let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
(let try () (let try ()
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(connect sock PF_UNIX "/run/udev/control") (connect sock PF_UNIX "/run/udev/control")
(close-port sock)) (close-port sock))
(lambda args (lambda args
(format #t "waiting for udevd...~%") (format #t "waiting for udevd...~%")
(usleep 500000) (usleep 500000)
(try)))))) (try))))))
;; Allow udev to find the modules. ;; Allow udev to find the modules.
(setenv "LINUX_MODULE_DIRECTORY" (setenv "LINUX_MODULE_DIRECTORY"
"/run/booted-system/kernel/lib/modules") "/run/booted-system/kernel/lib/modules")
;; The first one is for udev, the second one for eudev. ;; The first one is for udev, the second one for eudev.
(setenv "UDEV_CONFIG_FILE" #$udev.conf) (setenv "UDEV_CONFIG_FILE" #$udev.conf)
(setenv "EUDEV_RULES_DIRECTORY" (setenv "EUDEV_RULES_DIRECTORY"
(string-append #$rules "/lib/udev/rules.d")) (string-append #$rules "/lib/udev/rules.d"))
(let ((pid (primitive-fork))) (let ((pid (primitive-fork)))
(case pid (case pid
((0) ((0)
(exec-command (list udevd))) (exec-command (list udevd)))
(else (else
;; Wait until udevd is up and running. This ;; Wait until udevd is up and running. This
;; appears to be needed so that the events ;; appears to be needed so that the events
;; triggered below are actually handled. ;; triggered below are actually handled.
(wait-for-udevd) (wait-for-udevd)
;; Trigger device node creation. ;; Trigger device node creation.
(system* (string-append #$udev "/bin/udevadm") (system* (string-append #$udev "/bin/udevadm")
"trigger" "--action=add") "trigger" "--action=add")
;; Wait for things to settle down. ;; Wait for things to settle down.
(system* (string-append #$udev "/bin/udevadm") (system* (string-append #$udev "/bin/udevadm")
"settle") "settle")
pid))))) pid)))))
(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. Thus, make sure it is not respawned. ;; called. Thus, make sure it is not respawned.
(respawn? #f))))) (respawn? #f))))
(define (device-mapping-service target open close) (define (device-mapping-service target open close)
"Return a service that maps device @var{target}, a string such as "Return a service that maps device @var{target}, a string such as
@code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a @code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a
gexp, to open it, and evaluate @var{close} to close it." gexp, to open it, and evaluate @var{close} to close it."
(with-monad %store-monad (service
(return (service (provision (list (symbol-append 'device-mapping- (string->symbol target))))
(provision (list (symbol-append 'device-mapping- (requirement '(udev))
(string->symbol target)))) (documentation "Map a device node using Linux's device mapper.")
(requirement '(udev)) (start #~(lambda () #$open))
(documentation "Map a device node using Linux's device mapper.") (stop #~(lambda _ (not #$close)))
(start #~(lambda () #$open)) (respawn? #f)))
(stop #~(lambda _ (not #$close)))
(respawn? #f)))))
(define (swap-service device) (define (swap-service device)
"Return a service that uses @var{device} as a swap device." "Return a service that uses @var{device} as a swap device."
@ -839,18 +818,17 @@ gexp, to open it, and evaluate @var{close} to close it."
(string->symbol (basename device)))) (string->symbol (basename device))))
'())) '()))
(with-monad %store-monad (service
(return (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.") (start #~(lambda ()
(start #~(lambda () (restart-on-EINTR (swapon #$device))
(restart-on-EINTR (swapon #$device)) #t))
#t)) (stop #~(lambda _
(stop #~(lambda _ (restart-on-EINTR (swapoff #$device))
(restart-on-EINTR (swapoff #$device)) #f))
#f)) (respawn? #f)))
(respawn? #f)))))
(define %base-services (define %base-services
;; Convenience variable holding the basic services. ;; Convenience variable holding the basic services.

74
gnu/services/databases.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.
;;; ;;;
@ -22,7 +23,6 @@
#: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 monads)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
#:export (postgresql-service)) #:export (postgresql-service))
@ -34,23 +34,20 @@
;;; Code: ;;; Code:
(define %default-postgres-hba (define %default-postgres-hba
(text-file "pg_hba.conf" (plain-file "pg_hba.conf"
" "
local all all trust local all all trust
host all all 127.0.0.1/32 trust host all all 127.0.0.1/32 trust
host all all ::1/128 trust")) host all all ::1/128 trust"))
(define %default-postgres-ident (define %default-postgres-ident
(text-file "pg_ident.conf" (plain-file "pg_ident.conf"
"# MAPNAME SYSTEM-USERNAME PG-USERNAME")) "# MAPNAME SYSTEM-USERNAME PG-USERNAME"))
(define %default-postgres-config (define %default-postgres-config
(mlet %store-monad ((hba %default-postgres-hba) (mixed-text-file "postgresql.conf"
(ident %default-postgres-ident)) "hba_file = '" %default-postgres-hba "'\n"
(text-file* "postgresql.conf" "ident_file = '" %default-postgres-ident "\n"))
;; The daemon will not start without these.
"hba_file = '" hba "'\n"
"ident_file = '" ident "'\n")))
(define* (postgresql-service #:key (postgresql postgresql) (define* (postgresql-service #:key (postgresql postgresql)
(config-file %default-postgres-config) (config-file %default-postgres-config)
@ -62,16 +59,15 @@ and stores the database cluster in @var{data-directory}."
;; Wrapper script that switches to the 'postgres' user before launching ;; Wrapper script that switches to the 'postgres' user before launching
;; daemon. ;; daemon.
(define start-script (define start-script
(mlet %store-monad ((config-file config-file)) (program-file "start-postgres"
(gexp->script "start-postgres" #~(let ((user (getpwnam "postgres"))
#~(let ((user (getpwnam "postgres")) (postgres (string-append #$postgresql
(postgres (string-append #$postgresql "/bin/postgres")))
"/bin/postgres"))) (setgid (passwd:gid user))
(setgid (passwd:gid user)) (setuid (passwd:uid user))
(setuid (passwd:uid user)) (system* postgres
(system* postgres (string-append "--config-file=" #$config-file)
(string-append "--config-file=" #$config-file) "-D" #$data-directory))))
"-D" #$data-directory)))))
(define activate (define activate
#~(begin #~(begin
@ -99,23 +95,21 @@ and stores the database cluster in @var{data-directory}."
(primitive-exit 1)))) (primitive-exit 1))))
(pid (waitpid pid)))))) (pid (waitpid pid))))))
(mlet %store-monad ((start-script start-script)) (service
(return (provision '(postgres))
(service (documentation "Run the PostgreSQL daemon.")
(provision '(postgres)) (requirement '(user-processes loopback))
(documentation "Run the PostgreSQL daemon.") (start #~(make-forkexec-constructor #$start-script))
(requirement '(user-processes loopback)) (stop #~(make-kill-destructor))
(start #~(make-forkexec-constructor #$start-script)) (activate activate)
(stop #~(make-kill-destructor)) (user-groups (list (user-group
(activate activate) (name "postgres")
(user-groups (list (user-group (system? #t))))
(name "postgres") (user-accounts (list (user-account
(system? #t)))) (name "postgres")
(user-accounts (list (user-account (group "postgres")
(name "postgres") (system? #t)
(group "postgres") (comment "PostgreSQL server user")
(system? #t) (home-directory "/var/empty")
(comment "PostgreSQL server user") (shell
(home-directory "/var/empty") #~(string-append #$shadow "/sbin/nologin")))))))
(shell
#~(string-append #$shadow "/sbin/nologin")))))))))

420
gnu/services/desktop.scm
View file

@ -35,7 +35,6 @@
#:use-module (gnu packages polkit) #:use-module (gnu packages polkit)
#:use-module ((gnu packages linux) #:use-module ((gnu packages linux)
#:select (lvm2 fuse alsa-utils crda)) #:select (lvm2 fuse alsa-utils crda))
#:use-module (guix monads)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
@ -104,7 +103,7 @@
(sxml->xml (services->sxml (list #$@services)) (sxml->xml (services->sxml (list #$@services))
port))))) port)))))
(gexp->derivation "dbus-configuration" build)) (computed-file "dbus-configuration" build))
(define* (dbus-service services #:key (dbus dbus)) (define* (dbus-service services #:key (dbus 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
@ -118,50 +117,49 @@ be notified of system-wide events.
@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration @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, 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)}."
(mlet %store-monad ((conf (dbus-configuration-directory dbus services))) (let ((conf (dbus-configuration-directory dbus services)))
(return (service
(service (documentation "Run the D-Bus system daemon.")
(documentation "Run the D-Bus system daemon.") (provision '(dbus-system))
(provision '(dbus-system)) (requirement '(user-processes))
(requirement '(user-processes)) (start #~(make-forkexec-constructor
(start #~(make-forkexec-constructor (list (string-append #$dbus "/bin/dbus-daemon")
(list (string-append #$dbus "/bin/dbus-daemon") "--nofork"
"--nofork" (string-append "--config-file=" #$conf "/system.conf"))))
(string-append "--config-file=" #$conf "/system.conf")))) (stop #~(make-kill-destructor))
(stop #~(make-kill-destructor)) (user-groups (list (user-group
(user-groups (list (user-group (name "messagebus")
(name "messagebus") (system? #t))))
(system? #t)))) (user-accounts (list (user-account
(user-accounts (list (user-account (name "messagebus")
(name "messagebus") (group "messagebus")
(group "messagebus") (system? #t)
(system? #t) (comment "D-Bus system bus user")
(comment "D-Bus system bus user") (home-directory "/var/run/dbus")
(home-directory "/var/run/dbus") (shell
(shell #~(string-append #$shadow "/sbin/nologin")))))
#~(string-append #$shadow "/sbin/nologin"))))) (activate #~(begin
(activate #~(begin (use-modules (guix build utils))
(use-modules (guix build utils))
(mkdir-p "/var/run/dbus") (mkdir-p "/var/run/dbus")
(let ((user (getpwnam "messagebus"))) (let ((user (getpwnam "messagebus")))
(chown "/var/run/dbus" (chown "/var/run/dbus"
(passwd:uid user) (passwd:gid user))) (passwd:uid user) (passwd:gid user)))
(unless (file-exists? "/etc/machine-id") (unless (file-exists? "/etc/machine-id")
(format #t "creating /etc/machine-id...~%") (format #t "creating /etc/machine-id...~%")
(let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) (let ((prog (string-append #$dbus "/bin/dbus-uuidgen")))
;; XXX: We can't use 'system' because the initrd's ;; XXX: We can't use 'system' because the initrd's
;; guile system(3) only works when 'sh' is in $PATH. ;; guile system(3) only works when 'sh' is in $PATH.
(let ((pid (primitive-fork))) (let ((pid (primitive-fork)))
(if (zero? pid) (if (zero? pid)
(call-with-output-file "/etc/machine-id" (call-with-output-file "/etc/machine-id"
(lambda (port) (lambda (port)
(close-fdes 1) (close-fdes 1)
(dup2 (port->fdes port) 1) (dup2 (port->fdes port) 1)
(execl prog))) (execl prog)))
(waitpid pid))))))))))) (waitpid pid))))))))))
;;; ;;;
@ -175,24 +173,24 @@ and policy files. For example, to allow avahi-daemon to use the system bus,
time-critical time-action time-critical time-action
critical-power-action) critical-power-action)
"Return an upower-daemon configuration file." "Return an upower-daemon configuration file."
(text-file "UPower.conf" (plain-file "UPower.conf"
(string-append (string-append
"[UPower]\n" "[UPower]\n"
"EnableWattsUpPro=" (bool watts-up-pro?) "EnableWattsUpPro=" (bool watts-up-pro?)
"NoPollBatteries=" (bool (not poll-batteries?)) "NoPollBatteries=" (bool (not poll-batteries?))
"IgnoreLid=" (bool ignore-lid?) "IgnoreLid=" (bool ignore-lid?)
"UsePercentageForPolicy=" (bool use-percentage-for-policy?) "UsePercentageForPolicy=" (bool use-percentage-for-policy?)
"PercentageLow=" (number->string percentage-low) "\n" "PercentageLow=" (number->string percentage-low) "\n"
"PercentageCritical=" (number->string percentage-critical) "\n" "PercentageCritical=" (number->string percentage-critical) "\n"
"PercentageAction=" (number->string percentage-action) "\n" "PercentageAction=" (number->string percentage-action) "\n"
"TimeLow=" (number->string time-low) "\n" "TimeLow=" (number->string time-low) "\n"
"TimeCritical=" (number->string time-critical) "\n" "TimeCritical=" (number->string time-critical) "\n"
"TimeAction=" (number->string time-action) "\n" "TimeAction=" (number->string time-action) "\n"
"CriticalPowerAction=" (match critical-power-action "CriticalPowerAction=" (match critical-power-action
('hybrid-sleep "HybridSleep") ('hybrid-sleep "HybridSleep")
('hibernate "Hibernate") ('hibernate "Hibernate")
('power-off "PowerOff")) ('power-off "PowerOff"))
"\n"))) "\n")))
(define* (upower-service #:key (upower upower) (define* (upower-service #:key (upower upower)
(watts-up-pro? #f) (watts-up-pro? #f)
@ -210,47 +208,46 @@ 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."
(mlet %store-monad ((config (upower-configuration-file (let ((config (upower-configuration-file
#: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)))
(return (service
(service (documentation "Run the UPower power and battery monitor.")
(documentation "Run the UPower power and battery monitor.") (provision '(upower-daemon))
(provision '(upower-daemon)) (requirement '(dbus-system udev))
(requirement '(dbus-system udev))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$upower "/libexec/upowerd")) (list (string-append #$upower "/libexec/upowerd"))
#:environment-variables #:environment-variables
(list (string-append "UPOWER_CONF_FILE_NAME=" #$config)))) (list (string-append "UPOWER_CONF_FILE_NAME=" #$config))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(activate #~(begin (activate #~(begin
(use-modules (guix build utils)) (use-modules (guix build utils))
(mkdir-p "/var/lib/upower") (mkdir-p "/var/lib/upower")
(let ((user (getpwnam "upower"))) (let ((user (getpwnam "upower")))
(chown "/var/lib/upower" (chown "/var/lib/upower"
(passwd:uid user) (passwd:gid user))))) (passwd:uid user) (passwd:gid user)))))
(user-groups (list (user-group (user-groups (list (user-group
(name "upower") (name "upower")
(system? #t)))) (system? #t))))
(user-accounts (list (user-account (user-accounts (list (user-account
(name "upower") (name "upower")
(group "upower") (group "upower")
(system? #t) (system? #t)
(comment "UPower daemon user") (comment "UPower daemon user")
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (shell
#~(string-append #$shadow "/sbin/nologin"))))))))) #~(string-append #$shadow "/sbin/nologin"))))))))
;;; ;;;
@ -263,34 +260,32 @@ 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."
(with-monad %store-monad (service
(return (documentation "Run the colord color management service.")
(service (provision '(colord-daemon))
(documentation "Run the colord color management service.") (requirement '(dbus-system udev))
(provision '(colord-daemon))
(requirement '(dbus-system udev))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$colord "/libexec/colord")))) (list (string-append #$colord "/libexec/colord"))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(activate #~(begin (activate #~(begin
(use-modules (guix build utils)) (use-modules (guix build utils))
(mkdir-p "/var/lib/colord") (mkdir-p "/var/lib/colord")
(let ((user (getpwnam "colord"))) (let ((user (getpwnam "colord")))
(chown "/var/lib/colord" (chown "/var/lib/colord"
(passwd:uid user) (passwd:gid user))))) (passwd:uid user) (passwd:gid user)))))
(user-groups (list (user-group (user-groups (list (user-group
(name "colord") (name "colord")
(system? #t)))) (system? #t))))
(user-accounts (list (user-account (user-accounts (list (user-account
(name "colord") (name "colord")
(group "colord") (group "colord")
(system? #t) (system? #t)
(comment "colord daemon user") (comment "colord daemon user")
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (shell
#~(string-append #$shadow "/sbin/nologin"))))))))) #~(string-append #$shadow "/sbin/nologin")))))))
;;; ;;;
@ -321,16 +316,16 @@ users are allowed."
wifi-submission-url submission-nick wifi-submission-url submission-nick
applications) applications)
"Return a geoclue configuration file." "Return a geoclue configuration file."
(text-file "geoclue.conf" (plain-file "geoclue.conf"
(string-append (string-append
"[agent]\n" "[agent]\n"
"whitelist=" (string-join whitelist ";") "\n" "whitelist=" (string-join whitelist ";") "\n"
"[wifi]\n" "[wifi]\n"
"url=" wifi-geolocation-url "\n" "url=" wifi-geolocation-url "\n"
"submit-data=" (bool submit-data?) "submit-data=" (bool submit-data?)
"submission-url=" wifi-submission-url "\n" "submission-url=" wifi-submission-url "\n"
"submission-nick=" submission-nick "\n" "submission-nick=" submission-nick "\n"
(string-join applications "\n")))) (string-join applications "\n"))))
(define* (geoclue-service #:key (geoclue geoclue) (define* (geoclue-service #:key (geoclue geoclue)
(whitelist '()) (whitelist '())
@ -350,37 +345,36 @@ 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."
(mlet %store-monad ((config (geoclue-configuration-file (let ((config (geoclue-configuration-file
#:whitelist whitelist #:whitelist whitelist
#:wifi-geolocation-url wifi-geolocation-url #:wifi-geolocation-url wifi-geolocation-url
#:submit-data? submit-data? #:submit-data? submit-data?
#:wifi-submission-url wifi-submission-url #:wifi-submission-url wifi-submission-url
#:submission-nick submission-nick #:submission-nick submission-nick
#:applications applications))) #:applications applications)))
(return (service
(service (documentation "Run the GeoClue location service.")
(documentation "Run the GeoClue location service.") (provision '(geoclue-daemon))
(provision '(geoclue-daemon)) (requirement '(dbus-system))
(requirement '(dbus-system))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$geoclue "/libexec/geoclue")) (list (string-append #$geoclue "/libexec/geoclue"))
#:user "geoclue" #:user "geoclue"
#:environment-variables #:environment-variables
(list (string-append "GEOCLUE_CONFIG_FILE=" #$config)))) (list (string-append "GEOCLUE_CONFIG_FILE=" #$config))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(user-groups (list (user-group (user-groups (list (user-group
(name "geoclue") (name "geoclue")
(system? #t)))) (system? #t))))
(user-accounts (list (user-account (user-accounts (list (user-account
(name "geoclue") (name "geoclue")
(group "geoclue") (group "geoclue")
(system? #t) (system? #t)
(comment "GeoClue daemon user") (comment "GeoClue daemon user")
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (shell
"/run/current-system/profile/sbin/nologin")))))))) "/run/current-system/profile/sbin/nologin")))))))
;;; ;;;
@ -393,30 +387,28 @@ 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."
(with-monad %store-monad (service
(return (documentation "Run the polkit privilege management service.")
(service (provision '(polkit-daemon))
(documentation "Run the polkit privilege management service.") (requirement '(dbus-system))
(provision '(polkit-daemon))
(requirement '(dbus-system))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$polkit "/lib/polkit-1/polkitd")))) (list (string-append #$polkit "/lib/polkit-1/polkitd"))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(user-groups (list (user-group (user-groups (list (user-group
(name "polkitd") (name "polkitd")
(system? #t)))) (system? #t))))
(user-accounts (list (user-account (user-accounts (list (user-account
(name "polkitd") (name "polkitd")
(group "polkitd") (group "polkitd")
(system? #t) (system? #t)
(comment "Polkit daemon user") (comment "Polkit daemon user")
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (shell
"/run/current-system/profile/sbin/nologin")))) "/run/current-system/profile/sbin/nologin"))))
(pam-services (list (unix-pam-service "polkit-1"))))))) (pam-services (list (unix-pam-service "polkit-1")))))
;;; ;;;
@ -520,7 +512,7 @@ the system if the user is logged in locally."
((_ config str) ((_ config str)
(string-append str "\n")))) (string-append str "\n"))))
(define-syntax-rule (ini-file config file clause ...) (define-syntax-rule (ini-file config file clause ...)
(text-file file (string-append (ini-file-clause config clause) ...))) (plain-file file (string-append (ini-file-clause config clause) ...)))
(ini-file (ini-file
config "logind.conf" config "logind.conf"
"[Login]" "[Login]"
@ -562,18 +554,17 @@ 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 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 types (graphical, console, remote, etc.). It can also clean up after users
when they log out." when they log out."
(mlet %store-monad ((config-file (elogind-configuration-file config))) (let ((config-file (elogind-configuration-file config)))
(return (service
(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))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(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)))))
;;; ;;;
@ -599,25 +590,24 @@ when they log out."
(ntp-service) (ntp-service)
(map (lambda (mservice) (map (lambda (service)
(mlet %store-monad ((service mservice)) (cond
(cond ;; Provide an nscd ready to use nss-mdns.
;; Provide an nscd ready to use nss-mdns. ((memq 'nscd (service-provision service))
((memq 'nscd (service-provision service)) (nscd-service (nscd-configuration)
(nscd-service (nscd-configuration) #:name-services (list nss-mdns)))
#:name-services (list nss-mdns)))
;; Add more rules to udev-service. ;; Add more rules to udev-service.
;; ;;
;; XXX Keep this in sync with the 'udev-service' call in ;; XXX Keep this in sync with the 'udev-service' call in
;; %base-services. Here we intend only to add 'upower', ;; %base-services. Here we intend only to add 'upower',
;; 'colord', and 'elogind'. ;; 'colord', and 'elogind'.
((memq 'udev (service-provision service)) ((memq 'udev (service-provision service))
(udev-service #:rules (udev-service #:rules
(list lvm2 fuse alsa-utils crda (list lvm2 fuse alsa-utils crda
upower colord elogind))) upower colord elogind)))
(else mservice)))) (else service)))
%base-services))) %base-services)))
;;; desktop.scm ends here ;;; desktop.scm ends here

45
gnu/services/lirc.scm
View file

@ -19,7 +19,6 @@
(define-module (gnu services lirc) (define-module (gnu services lirc)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu packages lirc) #:use-module (gnu packages lirc)
#:use-module (guix monads)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
#:export (lirc-service)) #:export (lirc-service))
@ -41,28 +40,26 @@ The daemon will use specified @var{device}, @var{driver} and
Finally, @var{extra-options} is a list of additional command-line options Finally, @var{extra-options} is a list of additional command-line options
passed to @command{lircd}." passed to @command{lircd}."
(with-monad %store-monad (service
(return (provision '(lircd))
(service (documentation "Run the LIRC daemon.")
(provision '(lircd)) (requirement '(user-processes))
(documentation "Run the LIRC daemon.") (start #~(make-forkexec-constructor
(requirement '(user-processes)) (list (string-append #$lirc "/sbin/lircd")
(start #~(make-forkexec-constructor "--nodaemon"
(list (string-append #$lirc "/sbin/lircd") #$@(if device
"--nodaemon" #~("--device" #$device)
#$@(if device #~())
#~("--device" #$device) #$@(if driver
#~()) #~("--driver" #$driver)
#$@(if driver #~())
#~("--driver" #$driver) #$@(if config-file
#~()) #~(#$config-file)
#$@(if config-file #~())
#~(#$config-file) #$@extra-options)))
#~()) (stop #~(make-kill-destructor))
#$@extra-options))) (activate #~(begin
(stop #~(make-kill-destructor)) (use-modules (guix build utils))
(activate #~(begin (mkdir-p "/var/run/lirc")))))
(use-modules (guix build utils))
(mkdir-p "/var/run/lirc")))))))
;;; lirc.scm ends here ;;; lirc.scm ends here

335
gnu/services/networking.scm
View file

@ -28,7 +28,6 @@
#: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 store)
#:use-module (guix monads)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (%facebook-host-aliases #:export (%facebook-host-aliases
static-networking-service static-networking-service
@ -93,54 +92,52 @@ gateway."
;; TODO: Eventually replace 'route' with bindings for the appropriate ;; TODO: Eventually replace 'route' with bindings for the appropriate
;; ioctls. ;; ioctls.
(with-monad %store-monad (service
(return
(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.
(requirement (if loopback? '() '(udev))) (requirement (if loopback? '() '(udev)))
(documentation (documentation
"Bring up the networking interface using a static IP address.") "Bring up the networking interface using a static IP address.")
(provision provision) (provision provision)
(start #~(lambda _ (start #~(lambda _
;; Return #t if successfully started. ;; Return #t if successfully started.
(let* ((addr (inet-pton AF_INET #$ip)) (let* ((addr (inet-pton AF_INET #$ip))
(sockaddr (make-socket-address AF_INET addr 0))) (sockaddr (make-socket-address AF_INET addr 0)))
(configure-network-interface #$interface sockaddr (configure-network-interface #$interface sockaddr
(logior IFF_UP (logior IFF_UP
#$(if loopback? #$(if loopback?
#~IFF_LOOPBACK #~IFF_LOOPBACK
0)))) 0))))
#$(if gateway #$(if gateway
#~(zero? (system* (string-append #$net-tools #~(zero? (system* (string-append #$net-tools
"/sbin/route")
"add" "-net" "default"
"gw" #$gateway))
#t)
#$(if (pair? name-servers)
#~(call-with-output-file "/etc/resolv.conf"
(lambda (port)
(display
"# Generated by 'static-networking-service'.\n"
port)
(for-each (lambda (server)
(format port "nameserver ~a~%"
server))
'#$name-servers)))
#t)))
(stop #~(lambda _
;; Return #f is successfully stopped.
(let ((sock (socket AF_INET SOCK_STREAM 0)))
(set-network-interface-flags sock #$interface 0)
(close-port sock))
(not #$(if gateway
#~(system* (string-append #$net-tools
"/sbin/route") "/sbin/route")
"del" "-net" "default") "add" "-net" "default"
#t)))) "gw" #$gateway))
(respawn? #f))))) #t)
#$(if (pair? name-servers)
#~(call-with-output-file "/etc/resolv.conf"
(lambda (port)
(display
"# Generated by 'static-networking-service'.\n"
port)
(for-each (lambda (server)
(format port "nameserver ~a~%"
server))
'#$name-servers)))
#t)))
(stop #~(lambda _
;; Return #f is successfully stopped.
(let ((sock (socket AF_INET SOCK_STREAM 0)))
(set-network-interface-flags sock #$interface 0)
(close-port sock))
(not #$(if gateway
#~(system* (string-append #$net-tools
"/sbin/route")
"del" "-net" "default")
#t))))
(respawn? #f)))
(define* (dhcp-client-service #:key (dhcp isc-dhcp)) (define* (dhcp-client-service #:key (dhcp isc-dhcp))
"Return a service that runs @var{dhcp}, a Dynamic Host Configuration "Return a service that runs @var{dhcp}, a Dynamic Host Configuration
@ -152,52 +149,49 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
(define pid-file (define pid-file
"/var/run/dhclient.pid") "/var/run/dhclient.pid")
(with-monad %store-monad (service
(return (service (documentation "Set up networking via DHCP.")
(documentation "Set up networking via DHCP.") (requirement '(user-processes udev))
(requirement '(user-processes udev))
;; XXX: Running with '-nw' ("no wait") avoids blocking for a ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
;; minute when networking is unavailable, but also means that the ;; networking is unavailable, but also means that the interface is not up
;; interface is not up yet when 'start' completes. To wait for ;; yet when 'start' completes. To wait for the interface to be ready, one
;; the interface to be ready, one should instead monitor udev ;; should instead monitor udev events.
;; events. (provision '(networking))
(provision '(networking))
(start #~(lambda _ (start #~(lambda _
;; When invoked without any arguments, 'dhclient' ;; When invoked without any arguments, 'dhclient' discovers all
;; discovers all non-loopback interfaces *that are ;; non-loopback interfaces *that are up*. However, the relevant
;; up*. However, the relevant interfaces are ;; interfaces are typically down at this point. Thus we perform
;; typically down at this point. Thus we perform our ;; our own interface discovery here.
;; own interface discovery here. (define valid?
(define valid? (negate loopback-network-interface?))
(negate loopback-network-interface?)) (define ifaces
(define ifaces (filter valid? (all-network-interface-names)))
(filter valid? (all-network-interface-names)))
;; XXX: Make sure the interfaces are up so that ;; XXX: Make sure the interfaces are up so that 'dhclient' can
;; 'dhclient' can actually send/receive over them. ;; actually send/receive over them.
(for-each set-network-interface-up ifaces) (for-each set-network-interface-up ifaces)
(false-if-exception (delete-file #$pid-file)) (false-if-exception (delete-file #$pid-file))
(let ((pid (fork+exec-command (let ((pid (fork+exec-command
(cons* #$dhclient "-nw" (cons* #$dhclient "-nw"
"-pf" #$pid-file ifaces)))) "-pf" #$pid-file ifaces))))
(and (zero? (cdr (waitpid pid))) (and (zero? (cdr (waitpid pid)))
(let loop () (let loop ()
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(call-with-input-file #$pid-file read)) (call-with-input-file #$pid-file read))
(lambda args (lambda args
;; 'dhclient' returned before PID-FILE ;; 'dhclient' returned before PID-FILE was created,
;; was created, so try again. ;; so try again.
(let ((errno (system-error-errno args))) (let ((errno (system-error-errno args)))
(if (= ENOENT errno) (if (= ENOENT errno)
(begin (begin
(sleep 1) (sleep 1)
(loop)) (loop))
(apply throw args)))))))))) (apply throw args))))))))))
(stop #~(make-kill-destructor)))))) (stop #~(make-kill-destructor))))
(define %ntp-servers (define %ntp-servers
;; Default set of NTP servers. ;; Default set of NTP servers.
@ -227,57 +221,55 @@ 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"))
(mlet %store-monad ((ntpd.conf (text-file "ntpd.conf" config))) (let ((ntpd.conf (plain-file "ntpd.conf" config)))
(return (service
(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
(user-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* (tor-service #:key (tor tor))
"Return a service to run the @uref{https://torproject.org,Tor} daemon. "Return a service to run the @uref{https://torproject.org,Tor} daemon.
The daemon runs with the default settings (in particular the default exit The daemon runs with the default settings (in particular the default exit
policy) as the @code{tor} unprivileged user." policy) as the @code{tor} unprivileged user."
(mlet %store-monad ((torrc (text-file "torrc" "User tor\n"))) (let ((torrc (plain-file "torrc" "User tor\n")))
(return (service
(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
;; dependency on 'loopback'. ;; dependency on 'loopback'.
(requirement '(user-processes loopback)) (requirement '(user-processes loopback))
(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))
(user-groups (list (user-group (user-groups (list (user-group
(name "tor") (name "tor")
(system? #t)))) (system? #t))))
(user-accounts (list (user-account (user-accounts (list (user-account
(name "tor") (name "tor")
(group "tor") (group "tor")
(system? #t) (system? #t)
(comment "Tor daemon user") (comment "Tor 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."))))) (documentation "Run the Tor anonymous network overlay."))))
(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)
@ -292,60 +284,57 @@ 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."
(mlet %store-monad ((conf (text-file "bitlbee.conf" (let ((conf (plain-file "bitlbee.conf"
(string-append " (string-append "
[settings] [settings]
User = bitlbee User = bitlbee
ConfigDir = /var/lib/bitlbee ConfigDir = /var/lib/bitlbee
DaemonInterface = " interface " DaemonInterface = " interface "
DaemonPort = " (number->string port) " DaemonPort = " (number->string port) "
" extra-settings)))) " extra-settings))))
(return (service
(service (provision '(bitlbee))
(provision '(bitlbee)) (requirement '(user-processes loopback))
(requirement '(user-processes loopback)) (activate #~(begin
(activate #~(begin (use-modules (guix build utils))
(use-modules (guix build utils))
;; This directory is used to store OTR data. ;; This directory is used to store OTR data.
(mkdir-p "/var/lib/bitlbee") (mkdir-p "/var/lib/bitlbee")
(let ((user (getpwnam "bitlbee"))) (let ((user (getpwnam "bitlbee")))
(chown "/var/lib/bitlbee" (chown "/var/lib/bitlbee"
(passwd:uid user) (passwd:gid user))))) (passwd:uid user) (passwd:gid user)))))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$bitlbee "/sbin/bitlbee") (list (string-append #$bitlbee "/sbin/bitlbee")
"-n" "-F" "-u" "bitlbee" "-c" #$conf))) "-n" "-F" "-u" "bitlbee" "-c" #$conf)))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(user-groups (list (user-group (name "bitlbee") (system? #t)))) (user-groups (list (user-group (name "bitlbee") (system? #t))))
(user-accounts (list (user-account (user-accounts (list (user-account
(name "bitlbee") (name "bitlbee")
(group "bitlbee") (group "bitlbee")
(system? #t) (system? #t)
(comment "BitlBee daemon user") (comment "BitlBee daemon user")
(home-directory "/var/empty") (home-directory "/var/empty")
(shell #~(string-append #$shadow (shell #~(string-append #$shadow
"/sbin/nologin"))))))))) "/sbin/nologin"))))))))
(define* (wicd-service #:key (wicd wicd)) (define* (wicd-service #:key (wicd wicd))
"Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network "Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network
manager that aims to simplify wired and wireless networking." manager that aims to simplify wired and wireless networking."
(with-monad %store-monad (service
(return (documentation "Run the Wicd network manager.")
(service (provision '(networking))
(documentation "Run the Wicd network manager.") (requirement '(user-processes dbus-system loopback))
(provision '(networking)) (start #~(make-forkexec-constructor
(requirement '(user-processes dbus-system loopback)) (list (string-append #$wicd "/sbin/wicd")
(start #~(make-forkexec-constructor "--no-daemon")))
(list (string-append #$wicd "/sbin/wicd") (stop #~(make-kill-destructor))
"--no-daemon"))) (activate
(stop #~(make-kill-destructor)) #~(begin
(activate (use-modules (guix build utils))
#~(begin (mkdir-p "/etc/wicd")
(use-modules (guix build utils)) (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
(mkdir-p "/etc/wicd") (unless (file-exists? file-name)
(let ((file-name "/etc/wicd/dhclient.conf.template.default")) (copy-file (string-append #$wicd file-name)
(unless (file-exists? file-name) file-name)))))))
(copy-file (string-append #$wicd file-name)
file-name)))))))))
;;; networking.scm ends here ;;; networking.scm ends here

34
gnu/services/ssh.scm
View file

@ -19,7 +19,6 @@
(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 store)
#:use-module (guix monads)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu system linux) ; 'pam-service' #:use-module (gnu system linux) ; 'pam-service'
#:use-module (gnu packages lsh) #:use-module (gnu packages lsh)
@ -152,22 +151,21 @@ The other options should be self-descriptive."
'(networking syslogd) '(networking syslogd)
'(networking))) '(networking)))
(with-monad %store-monad (service
(return (service (documentation "GNU lsh SSH server")
(documentation "GNU lsh SSH server") (provision '(ssh-daemon))
(provision '(ssh-daemon)) (requirement requires)
(requirement requires) (start #~(make-forkexec-constructor (list #$@lsh-command)))
(start #~(make-forkexec-constructor (list #$@lsh-command))) (stop #~(make-kill-destructor))
(stop #~(make-kill-destructor)) (pam-services
(pam-services (list (unix-pam-service
(list (unix-pam-service "lshd"
"lshd" #:allow-empty-passwords? allow-empty-passwords?)))
#:allow-empty-passwords? allow-empty-passwords?))) (activate #~(begin
(activate #~(begin (use-modules (guix build utils))
(use-modules (guix build utils)) (mkdir-p "/var/spool/lsh")
(mkdir-p "/var/spool/lsh") #$(if initialize?
#$(if initialize? (activation lsh host-key)
(activation lsh host-key) #t)))))
#t)))))))
;;; ssh.scm ends here ;;; ssh.scm ends here

37
gnu/services/web.scm
View file

@ -22,7 +22,6 @@
#: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 monads)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
#:export (nginx-service)) #:export (nginx-service))
@ -76,22 +75,20 @@ files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY."
(define nologin #~(string-append #$shadow "/sbin/nologin")) (define nologin #~(string-append #$shadow "/sbin/nologin"))
;; TODO: Add 'reload' action. ;; TODO: Add 'reload' action.
(mbegin %store-monad (service
(return (provision '(nginx))
(service (documentation "Run the nginx daemon.")
(provision '(nginx)) (requirement '(user-processes loopback))
(documentation "Run the nginx daemon.") (start (nginx-action "-p" run-directory))
(requirement '(user-processes loopback)) (stop (nginx-action "-s" "stop"))
(start (nginx-action "-p" run-directory)) (activate activate)
(stop (nginx-action "-s" "stop")) (user-groups (list (user-group
(activate activate) (name "nginx")
(user-groups (list (user-group (system? #t))))
(name "nginx") (user-accounts (list (user-account
(system? #t)))) (name "nginx")
(user-accounts (list (user-account (group "nginx")
(name "nginx") (system? #t)
(group "nginx") (comment "nginx server user")
(system? #t) (home-directory "/var/empty")
(comment "nginx server user") (shell nologin))))))
(home-directory "/var/empty")
(shell nologin))))))))

119
gnu/services/xorg.scm
View file

@ -31,7 +31,6 @@
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix records) #:use-module (guix records)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -63,8 +62,8 @@ appropriate screen resolution; otherwise, it must be a list of
resolutions---e.g., @code{((1024 768) (640 480))}. resolutions---e.g., @code{((1024 768) (640 480))}.
Last, @var{extra-config} is a list of strings or objects appended to the Last, @var{extra-config} is a list of strings or objects appended to the
@code{text-file*} argument list. It is used to pass extra text to be added @code{mixed-text-file} argument list. It is used to pass extra text to be
verbatim to the configuration file." added verbatim to the configuration file."
(define (device-section driver) (define (device-section driver)
(string-append " (string-append "
Section \"Device\" Section \"Device\"
@ -87,7 +86,7 @@ Section \"Screen\"
EndSubSection EndSubSection
EndSection")) EndSection"))
(apply text-file* "xserver.conf" " (apply mixed-text-file "xserver.conf" "
Section \"Files\" Section \"Files\"
FontPath \"" font-adobe75dpi "/share/fonts/X11/75dpi\" FontPath \"" font-adobe75dpi "/share/fonts/X11/75dpi\"
ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\"
@ -128,7 +127,7 @@ EndSection
(define* (xorg-start-command #:key (define* (xorg-start-command #:key
(guile (canonical-package guile-2.0)) (guile (canonical-package guile-2.0))
configuration-file (configuration-file (xorg-configuration-file))
(xorg-server xorg-server)) (xorg-server xorg-server))
"Return a derivation that builds a @var{guile} script to start the X server "Return a derivation that builds a @var{guile} script to start the X server
from @var{xorg-server}. @var{configuration-file} is the server configuration from @var{xorg-server}. @var{configuration-file} is the server configuration
@ -136,27 +135,24 @@ file or a derivation that builds it; when omitted, the result of
@code{xorg-configuration-file} is used. @code{xorg-configuration-file} is used.
Usually the X server is started by a login manager." Usually the X server is started by a login manager."
(mlet %store-monad ((config (if configuration-file (define exp
(return configuration-file) ;; Write a small wrapper around the X server.
(xorg-configuration-file)))) #~(begin
(define script (setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri"))
;; Write a small wrapper around the X server. (setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin"))
#~(begin
(setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri"))
(setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin"))
(apply execl (string-append #$xorg-server "/bin/X") (apply execl (string-append #$xorg-server "/bin/X")
(string-append #$xorg-server "/bin/X") ;argv[0] (string-append #$xorg-server "/bin/X") ;argv[0]
"-logverbose" "-verbose" "-logverbose" "-verbose"
"-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb")
"-config" #$config "-config" #$configuration-file
"-nolisten" "tcp" "-terminate" "-nolisten" "tcp" "-terminate"
;; Note: SLiM and other display managers add the ;; Note: SLiM and other display managers add the
;; '-auth' flag by themselves. ;; '-auth' flag by themselves.
(cdr (command-line))))) (cdr (command-line)))))
(gexp->script "start-xorg" script))) (program-file "start-xorg" exp))
(define* (xinitrc #:key (define* (xinitrc #:key
(guile (canonical-package guile-2.0)) (guile (canonical-package guile-2.0))
@ -200,7 +196,7 @@ which should be passed to this script as the first argument. If not, the
(exec-from-login-shell xsession-file session) (exec-from-login-shell xsession-file session)
;; Otherwise, start the specified session. ;; Otherwise, start the specified session.
(exec-from-login-shell session))))) (exec-from-login-shell session)))))
(gexp->script "xinitrc" builder)) (program-file "xinitrc" builder))
;;; ;;;
@ -224,7 +220,7 @@ which should be passed to this script as the first argument. If not, the
(xauth xauth) (dmd dmd) (bash bash) (xauth xauth) (dmd dmd) (bash bash)
(auto-login-session #~(string-append #$windowmaker (auto-login-session #~(string-append #$windowmaker
"/bin/wmaker")) "/bin/wmaker"))
startx) (startx (xorg-start-command)))
"Return a service that spawns the SLiM graphical login manager, which in "Return a service that spawns the SLiM graphical login manager, which in
turn starts the X display server with @var{startx}, a command as returned by turn starts the X display server with @var{startx}, a command as returned by
@code{xorg-start-command}. @code{xorg-start-command}.
@ -251,13 +247,9 @@ If @var{theme} is @code{#f}, the use the default log-in theme; otherwise
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."
(define (slim.cfg) (define slim.cfg
(mlet %store-monad ((startx (if startx (let ((xinitrc (xinitrc #:fallback-session auto-login-session)))
(return startx) (mixed-text-file "slim.cfg" "
(xorg-start-command)))
(xinitrc (xinitrc #:fallback-session
auto-login-session)))
(text-file* "slim.cfg" "
default_path /run/current-system/profile/bin default_path /run/current-system/profile/bin
default_xserver " startx " default_xserver " startx "
xserver_arguments :0 vt7 xserver_arguments :0 vt7
@ -271,40 +263,37 @@ sessiondir /run/current-system/profile/share/xsessions
session_msg session (F1 to change): session_msg session (F1 to change):
halt_cmd " dmd "/sbin/halt halt_cmd " dmd "/sbin/halt
reboot_cmd " dmd "/sbin/reboot reboot_cmd " dmd "/sbin/reboot\n"
" (if auto-login?
(if auto-login? (string-append "auto_login yes\ndefault_user " default-user "\n")
(string-append "auto_login yes\ndefault_user " default-user "\n") "")
"") (if theme-name
(if theme-name (string-append "current_theme " theme-name "\n")
(string-append "current_theme " theme-name "\n") ""))))
""))))
(mlet %store-monad ((slim.cfg (slim.cfg))) (service
(return (documentation "Xorg display server")
(service (provision '(xorg-server))
(documentation "Xorg display server") (requirement '(user-processes host-name udev))
(provision '(xorg-server)) (start
(requirement '(user-processes host-name udev)) #~(lambda ()
(start ;; A stale lock file can prevent SLiM from starting, so remove it
#~(lambda () ;; to be on the safe side.
;; A stale lock file can prevent SLiM from starting, so remove it (false-if-exception (delete-file "/var/run/slim.lock"))
;; to be on the safe side.
(false-if-exception (delete-file "/var/run/slim.lock"))
(fork+exec-command (fork+exec-command
(list (string-append #$slim "/bin/slim") "-nodaemon") (list (string-append #$slim "/bin/slim") "-nodaemon")
#:environment-variables #:environment-variables
(list (string-append "SLIM_CFGFILE=" #$slim.cfg) (list (string-append "SLIM_CFGFILE=" #$slim.cfg)
#$@(if theme #$@(if theme
(list #~(string-append "SLIM_THEMESDIR=" #$theme)) (list #~(string-append "SLIM_THEMESDIR=" #$theme))
#~()))))) #~())))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(respawn? #t) (respawn? #t)
(pam-services (pam-services
;; Tell PAM about 'slim'. ;; Tell PAM about 'slim'.
(list (unix-pam-service (list (unix-pam-service
"slim" "slim"
#:allow-empty-passwords? allow-empty-passwords?))))))) #:allow-empty-passwords? allow-empty-passwords?)))))
;;; xorg.scm ends here ;;; xorg.scm ends here

104
gnu/system.scm
View file

@ -244,19 +244,18 @@ as 'needed-for-boot'."
(string->symbol (mapped-device-target md)))) (string->symbol (mapped-device-target md))))
(device-mappings fs)))) (device-mappings fs))))
(sequence %store-monad (map (lambda (fs)
(map (lambda (fs) (match fs
(match fs (($ <file-system> device title target type flags opts
(($ <file-system> device title target type flags opts #f check? create?)
#f check? create?) (file-system-service device target type
(file-system-service device target type #:title title
#:title title #:requirements (requirements fs)
#:requirements (requirements fs) #:check? check?
#:check? check? #:create-mount-point? create?
#:create-mount-point? create? #:options opts
#:options opts #:flags flags))))
#:flags flags)))) file-systems))
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."
@ -287,23 +286,21 @@ from the initrd."
devices))) devices)))
(define (device-mapping-services os) (define (device-mapping-services os)
"Return the list of device-mapping services for OS as a monadic list." "Return the list of device-mapping services for OS as a list."
(sequence %store-monad (map (lambda (md)
(map (lambda (md) (let* ((source (mapped-device-source md))
(let* ((source (mapped-device-source md)) (target (mapped-device-target md))
(target (mapped-device-target md)) (type (mapped-device-type md))
(type (mapped-device-type md)) (open (mapped-device-kind-open type))
(open (mapped-device-kind-open type)) (close (mapped-device-kind-close type)))
(close (mapped-device-kind-close type))) (device-mapping-service target
(device-mapping-service target (open source target)
(open source target) (close source target))))
(close source target)))) (operating-system-user-mapped-devices os)))
(operating-system-user-mapped-devices os))))
(define (swap-services os) (define (swap-services os)
"Return the list of swap services for OS as a monadic list." "Return the list of swap services for OS."
(sequence %store-monad (map swap-service (operating-system-swap-devices os)))
(map swap-service (operating-system-swap-devices os))))
(define (essential-services os) (define (essential-services os)
"Return the list of essential services for OS. These are special services "Return the list of essential services for OS. These are special services
@ -312,26 +309,23 @@ bookkeeping."
(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)))
(mlet* %store-monad ((mappings (device-mapping-services os)) (let* ((mappings (device-mapping-services os))
(root-fs (root-file-system-service)) (root-fs (root-file-system-service))
(other-fs (other-file-system-services os)) (other-fs (other-file-system-services os))
(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 (compose first service-provision)
other-fs))) other-fs)))
(host-name (host-name-service (host-name (host-name-service (operating-system-host-name os))))
(operating-system-host-name os)))) (cons* host-name procs root-fs unmount
(return (cons* host-name procs root-fs unmount (append other-fs mappings swaps))))
(append other-fs mappings swaps)))))
(define (operating-system-services os) (define (operating-system-services os)
"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."
(mlet %store-monad (append (operating-system-user-services os)
((user (sequence %store-monad (operating-system-user-services os))) (essential-services os)))
(essential (essential-services os)))
(return (append essential user))))
;;; ;;;
@ -420,8 +414,7 @@ settings for 'guix.el' to work out-of-the-box."
(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
gexps or strings." gexps or strings."
(mlet %store-monad ((accounts (operating-system-accounts os))) (map user-account-shell (operating-system-accounts os)))
(return (map user-account-shell accounts))))
(define (shells-file shells) (define (shells-file shells)
"Return a derivation that builds a shell list for use as /etc/shells based "Return a derivation that builds a shell list for use as /etc/shells based
@ -577,9 +570,9 @@ fi\n"))
(operating-system-users os) (operating-system-users os)
(cons %root-account (operating-system-users os)))) (cons %root-account (operating-system-users os))))
(mlet %store-monad ((services (operating-system-services os))) (append users
(return (append users (append-map service-user-accounts
(append-map service-user-accounts services))))) (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.
@ -615,7 +608,7 @@ 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 (mlet* %store-monad
((services (operating-system-services os)) ((services -> (operating-system-services os))
(pam-services -> (pam-services ->
;; Services known to PAM. ;; Services known to PAM.
(append (operating-system-pam-services os) (append (operating-system-pam-services os)
@ -626,7 +619,7 @@ use 'plain-file' instead~%")
"hosts" "hosts"
(or (operating-system-hosts-file os) (or (operating-system-hosts-file os)
(default-/etc/hosts (operating-system-host-name os))))) (default-/etc/hosts (operating-system-host-name os)))))
(shells (user-shells os))) (shells -> (user-shells os)))
(etc-directory #:pam-services pam-services (etc-directory #:pam-services pam-services
#:skeletons skeletons #:skeletons skeletons
#:issue (operating-system-issue os) #:issue (operating-system-issue os)
@ -713,7 +706,7 @@ etc."
(sequence %store-monad (map (cut gexp->file "activate-service.scm" <>) (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>)
gexps)))) gexps))))
(mlet* %store-monad ((services (operating-system-services os)) (mlet* %store-monad ((services -> (operating-system-services os))
(actions (service-activations services)) (actions (service-activations services))
(etc (operating-system-etc-directory os)) (etc (operating-system-etc-directory os))
(modules (imported-modules %modules)) (modules (imported-modules %modules))
@ -721,7 +714,7 @@ etc."
(modprobe (modprobe-wrapper)) (modprobe (modprobe-wrapper))
(firmware (directory-union (firmware (directory-union
"firmware" (operating-system-firmware os))) "firmware" (operating-system-firmware os)))
(accounts (operating-system-accounts os))) (accounts -> (operating-system-accounts os)))
(define setuid-progs (define setuid-progs
(operating-system-setuid-programs os)) (operating-system-setuid-programs os))
@ -789,9 +782,8 @@ etc."
"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)) (mlet* %store-monad ((services -> (operating-system-services os))
(activate (operating-system-activation-script (activate (operating-system-activation-script os))
os #:container? container?))
(dmd-conf (dmd-configuration-file services))) (dmd-conf (dmd-configuration-file services)))
(gexp->file "boot" (gexp->file "boot"
#~(begin #~(begin

80
gnu/system/install.scm
View file

@ -163,32 +163,31 @@ current store is on a RAM disk."
"Return a service that makes the store copy-on-write, such that writes go to "Return a service that makes the store copy-on-write, such that writes go to
the user's target storage device rather than on the RAM disk." the user's target storage device rather than on the RAM disk."
;; See <http://bugs.gnu.org/18061> for the initial report. ;; See <http://bugs.gnu.org/18061> for the initial report.
(with-monad %store-monad (service
(return (service (requirement '(root-file-system user-processes))
(requirement '(root-file-system user-processes)) (provision '(cow-store))
(provision '(cow-store)) (documentation
(documentation "Make the store copy-on-write, with writes going to \
"Make the store copy-on-write, with writes going to \
the given target.") the given target.")
;; This is meant to be explicitly started by the user. ;; This is meant to be explicitly started by the user.
(auto-start? #f) (auto-start? #f)
(start #~(case-lambda (start #~(case-lambda
((target) ((target)
#$(make-cow-store #~target) #$(make-cow-store #~target)
target) target)
(else (else
;; Do nothing, and mark the service as stopped. ;; Do nothing, and mark the service as stopped.
#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 'user-processes' doesn't depend on us. The ;; since 'user-processes' doesn't depend on us. The
;; 'user-unmount' service will unmount TARGET ;; 'user-unmount' 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 (configuration-template-service)
"Return a dummy service whose purpose is to install an operating system "Return a dummy service whose purpose is to install an operating system
@ -204,25 +203,24 @@ configuration template file in the installation system."
'(("gnu/system/examples/bare-bones.tmpl" -> "bare-bones.scm") '(("gnu/system/examples/bare-bones.tmpl" -> "bare-bones.scm")
("gnu/system/examples/desktop.tmpl" -> "desktop.scm")))) ("gnu/system/examples/desktop.tmpl" -> "desktop.scm"))))
(with-monad %store-monad (service
(return (service (requirement '(root-file-system))
(requirement '(root-file-system)) (provision '(os-config-template))
(provision '(os-config-template)) (documentation
(documentation "This dummy service installs an OS configuration template.")
"This dummy service installs an OS configuration template.") (start #~(const #t))
(start #~(const #t)) (stop #~(const #f))
(stop #~(const #f)) (activate
(activate #~(begin
#~(begin (use-modules (ice-9 match)
(use-modules (ice-9 match) (guix build utils))
(guix build utils))
(mkdir-p "/etc/configuration") (mkdir-p "/etc/configuration")
(for-each (match-lambda (for-each (match-lambda
((file target) ((file target)
(unless (file-exists? target) (unless (file-exists? target)
(copy-file file target)))) (copy-file file target))))
'#$templates))))))) '#$templates)))))
(define %nscd-minimal-caches (define %nscd-minimal-caches
;; Minimal in-memory caching policy for nscd. ;; Minimal in-memory caching policy for nscd.