diff options
57 files changed, 4837 insertions, 2124 deletions
diff --git a/.gitignore b/.gitignore index a363c074ca..e3f2ac2c21 100644 --- a/.gitignore +++ b/.gitignore @@ -129,3 +129,6 @@ GTAGS /doc/images/coreutils-bag-graph.png /doc/images/coreutils-graph.png /doc/images/coreutils-size-map.eps +/doc/images/service-graph.png +/doc/images/service-graph.eps +/doc/images/service-graph.pdf diff --git a/Makefile.am b/Makefile.am index a8dab5d326..18fbd9d578 100644 --- a/Makefile.am +++ b/Makefile.am @@ -219,6 +219,7 @@ SCM_TESTS = \ tests/size.scm \ tests/graph.scm \ tests/file-systems.scm \ + tests/services.scm \ tests/containers.scm if HAVE_GUILE_JSON @@ -40,6 +40,7 @@ infrastructure help: Alexander Shendi <Alexander.Shendi@web.de> Alen Skondro <askondro@gmail.com> Matthias Wachs <wachs@net.in.tum.de> +Christopher Allan Webber <cwebber@dustycloud.org> Philip Woods <elzairthesorcerer@gmail.com> GNU Guix also includes non-software works. Thanks to the following diff --git a/config-daemon.ac b/config-daemon.ac index f96cc8f7ac..8c1c776133 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -51,7 +51,7 @@ if test "x$guix_build_daemon" = "xyes"; then no) LIBGCRYPT_LIBS="-lgcrypt" ;; - *) + *) LIBGCRYPT_LIBS="-L$LIBGCRYPT_LIBDIR -lgcrypt" ;; esac diff --git a/configure.ac b/configure.ac index 38e9ec56b7..bb3d947535 100644 --- a/configure.ac +++ b/configure.ac @@ -169,6 +169,9 @@ case "x$LIBGCRYPT_PREFIX$LIBGCRYPT_LIBDIR" in GUIX_LIBGCRYPT_LIBDIR([LIBGCRYPT_LIBDIR]) if test "x$LIBGCRYPT_LIBDIR" != x; then LIBGCRYPT="$LIBGCRYPT_LIBDIR/libgcrypt" + else + dnl 'config-daemon.ac' expects "no" in this case. + LIBGCRYPT_LIBDIR="no" fi ;; esac @@ -22,7 +22,8 @@ info_TEXINFOS = doc/guix.texi DOT_FILES = \ doc/images/bootstrap-graph.dot \ doc/images/coreutils-graph.dot \ - doc/images/coreutils-bag-graph.dot + doc/images/coreutils-bag-graph.dot \ + doc/images/service-graph.dot DOT_VECTOR_GRAPHICS = \ $(DOT_FILES:%.dot=%.eps) \ diff --git a/doc/emacs.texi b/doc/emacs.texi index b6f2701bc4..ab69515972 100644 --- a/doc/emacs.texi +++ b/doc/emacs.texi @@ -667,6 +667,16 @@ this command---for example, with @kbd{C-M-x} (@pxref{To eval or not to eval,,, geiser, Geiser User Manual}) (@code{guix-devel-build-package-definition}). +@item C-c . s +Build a source derivation of the package defined by the current variable +definition. This command has the same meaning as @code{guix build -S} +shell command (@pxref{Invoking guix build}) +(@code{guix-devel-build-package-source}). + +@item C-c . l +Lint (check) a package defined by the current variable definition +(@pxref{Invoking guix lint}) (@code{guix-devel-lint-package}). + @end table Unluckily, there is a limitation related to long-running REPL commands. diff --git a/doc/guix.texi b/doc/guix.texi index 79877f156b..709ec0ff70 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -182,6 +182,13 @@ Services * Web Services:: Web servers. * Various Services:: Other services. +Defining Services + +* Service Composition:: The model for composing services. +* Service Types and Services:: Types and services. +* Service Reference:: API reference. +* dmd Services:: A particular type of service. + Packaging Guidelines * Software Freedom:: What may go into the distribution. @@ -3367,7 +3374,8 @@ The other arguments are as for @code{derivation} (@pxref{Derivations}). @end deffn @cindex file-like objects -The @code{local-file} and @code{plain-file} procedures below return +The @code{local-file}, @code{plain-file}, @code{computed-file}, +@code{program-file}, and @code{scheme-file} procedures below return @dfn{file-like objects}. That is, when unquoted in a G-expression, these objects lead to a file in the store. Consider this G-expression: @@ -3405,6 +3413,16 @@ Return an object representing a text file called @var{name} with the given This is the declarative counterpart of @code{text-file}. @end deffn +@deffn {Scheme Procedure} computed-file @var{name} @var{gexp} @ + [#:modules '()] [#:options '(#:local-build? #t)] +Return an object representing the store item @var{name}, a file or +directory computed by @var{gexp}. @var{modules} specifies the set of +modules visible in the execution context of @var{gexp}. @var{options} +is a list of additional arguments to pass to @code{gexp->derivation}. + +This is the declarative counterpart of @code{gexp->derivation}. +@end deffn + @deffn {Monadic Procedure} gexp->script @var{name} @var{exp} Return an executable script @var{name} that runs @var{exp} using @var{guile} with @var{modules} in its search path. @@ -3432,6 +3450,15 @@ executable file @file{/gnu/store/@dots{}-list-files} along these lines: @end example @end deffn +@deffn {Scheme Procedure} program-file @var{name} @var{exp} @ + [#:modules '()] [#:guile #f] +Return an object representing the executable store item @var{name} that +runs @var{gexp}. @var{guile} is the Guile package used to execute that +script, and @var{modules} is the list of modules visible to that script. + +This is the declarative counterpart of @code{gexp->script}. +@end deffn + @deffn {Monadic Procedure} gexp->file @var{name} @var{exp} Return a derivation that builds a file @var{name} containing @var{exp}. @@ -3439,6 +3466,13 @@ The resulting file holds references to all the dependencies of @var{exp} or a subset thereof. @end deffn +@deffn {Scheme Procedure} scheme-file @var{name} @var{exp} +Return an object representing the Scheme file @var{name} that contains +@var{exp}. + +This is the declarative counterpart of @code{gexp->file}. +@end deffn + @deffn {Monadic Procedure} text-file* @var{name} @var{text} @dots{} Return as a monadic value a derivation that builds a text file containing all of @var{text}. @var{text} may list, in addition to @@ -3465,6 +3499,19 @@ will references @var{coreutils}, @var{grep}, and @var{sed}, thereby preventing them from being garbage-collected during its lifetime. @end deffn +@deffn {Scheme Procedure} mixed-text-file @var{name} @var{text} @dots{} +Return an object representing store file @var{name} containing +@var{text}. @var{text} is a sequence of strings and file-like objects, +as in: + +@example +(mixed-text-file "profile" + "export PATH=" coreutils "/bin:" grep "/bin") +@end example + +This is the declarative counterpart of @code{text-file*}. +@end deffn + Of course, in addition to gexps embedded in ``host'' code, there are also modules containing build tools. To make it clear that they are meant to be used in the build stratum, these modules are kept in the @@ -4560,11 +4607,12 @@ and Emacs are available: guix environment guile emacs @end example -Sometimes an interactive shell session is not desired. The -@code{--exec} option can be used to specify the command to run instead. +Sometimes an interactive shell session is not desired. An arbitrary +command may be invoked by placing the @code{--} token to separate the +command from the rest of the arguments: @example -guix environment guile --exec=make +guix environment guile -- make -j4 @end example In other situations, it is more convenient to specify the list of @@ -4573,7 +4621,7 @@ runs @command{python} from an environment containing Python@tie{}2.7 and NumPy: @example -guix environment --ad-hoc python2-numpy python-2.7 -E python +guix environment --ad-hoc python2-numpy python-2.7 -- python @end example The available options are summarized below. @@ -4604,11 +4652,6 @@ As an example, @var{file} might contain a definition like this @verbatiminclude environment-gdb.scm @end example - -@item --exec=@var{command} -@item -E @var{command} -Execute @var{command} in the new environment. - @item --ad-hoc Include all specified packages in the resulting environment, as if an @i{ad hoc} package were defined with them as inputs. This option is @@ -4618,7 +4661,7 @@ package expression to contain the desired inputs. For instance, the command: @example -guix environment --ad-hoc guile guile-sdl -E guile +guix environment --ad-hoc guile guile-sdl -- guile @end example runs @command{guile} in an environment where Guile and Guile-SDL are @@ -5743,38 +5786,55 @@ this: @end example @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}. @end deffn -@deffn {Monadic Procedure} mingetty-service @var{tty} [#:motd] @ - [#:auto-login #f] [#:login-program] [#:login-pause? #f] @ - [#:allow-empty-passwords? #f] -Return a service to run mingetty on @var{tty}. +@deffn {Scheme Procedure} mingetty-service @var{config} +Return a service to run mingetty according to @var{config}, a +@code{<mingetty-configuration>} object, which specifies the tty to run, among +other things. +@end deffn -When @var{allow-empty-passwords?} is true, allow empty log-in password. When -@var{auto-login} is true, it must be a user name under which to log-in -automatically. @var{login-pause?} can be set to @code{#t} in conjunction with -@var{auto-login}, in which case the user will have to press a key before the -login shell is launched. +@deftp {Data Type} mingetty-configuration +This is the data type representing the configuration of Mingetty, which +implements console log-in. -When true, @var{login-program} is a gexp or a monadic gexp denoting the name -of the log-in program (the default is the @code{login} program from the Shadow -tool suite.) +@table @asis -@var{motd} is a monadic value containing a text file to use as -the ``message of the day''. -@end deffn +@item @code{tty} +The name of the console this Mingetty runs on---e.g., @code{"tty1"}. + +@item @code{motd} +A file-like object containing the ``message of the day''. + +@item @code{auto-login} (default: @code{#f}) +When true, this field must be a string denoting the user name under +which the the system automatically logs in. When it is @code{#f}, a +user name and password must be entered to log in. + +@item @code{login-program} (default: @code{#f}) +This must be either @code{#f}, in which case the default log-in program +is used (@command{login} from the Shadow tool suite), or a gexp denoting +the name of the log-in program. + +@item @code{login-pause?} (default: @code{#f}) +When set to @code{#t} in conjunction with @var{auto-login}, the user +will have to press a key before the log-in shell is launched. + +@item @code{mingetty} (default: @var{mingetty}) +The Mingetty package to use. + +@end table +@end deftp @cindex name service cache daemon @cindex nscd -@deffn {Monadic Procedure} nscd-service [@var{config}] [#:glibc glibc] @ +@deffn {Scheme Procedure} nscd-service [@var{config}] [#:glibc glibc] @ [#:name-services '()] -Return a service that runs libc's name service cache daemon (nscd) with -the given @var{config}---an @code{<nscd-configuration>} object. -Optionally, @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. +Return a service that runs libc's name service cache daemon (nscd) with the +given @var{config}---an @code{<nscd-configuration>} object. @xref{Name +Service Switch}, for an example. @end deffn @defvr {Scheme Variable} %nscd-default-configuration @@ -5789,6 +5849,14 @@ configuration. @table @asis +@item @code{name-services} (default: @code{'()}) +List of packages denoting @dfn{name services} that must be visible to +the nscd---e.g., @code{(list @var{nss-mdns})}. + +@item @code{glibc} (default: @var{glibc}) +Package object denoting the GNU C Library providing the @command{nscd} +command. + @item @code{log-file} (default: @code{"/var/log/nscd.log"}) Name of nscd's log file. This is where debugging output goes when @code{debug-level} is strictly positive. @@ -5855,36 +5923,54 @@ external name servers do not even need to be queried. @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 @var{config-file} is not specified, use some reasonable default settings. @end deffn -@deffn {Monadic Procedure} guix-service [#:guix guix] @ - [#:builder-group "guixbuild"] [#:build-accounts 10] @ - [#:authorize-hydra-key? #t] [#:use-substitutes? #t] @ - [#:extra-options '()] -Return a service that runs the build daemon from @var{guix}, and has -@var{build-accounts} user accounts available under @var{builder-group}. +@anchor{guix-configuration-type} +@deftp {Data Type} guix-configuration +This data type represents the configuration of the Guix build daemon. +@xref{Invoking guix-daemon}, for more information. -When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key -provided by @var{guix} is authorized upon activation, meaning that substitutes -from @code{hydra.gnu.org} are used by default. +@table @asis +@item @code{guix} (default: @var{guix}) +The Guix package to use. -If @var{use-substitutes?} is false, the daemon is run with -@option{--no-substitutes} (@pxref{Invoking guix-daemon, -@option{--no-substitutes}}). +@item @code{build-group} (default: @code{"guixbuild"}) +Name of the group for build user accounts. -Finally, @var{extra-options} is a list of additional command-line options -passed to @command{guix-daemon}. +@item @code{build-accounts} (default: @code{10}) +Number of build user accounts to create. + +@item @code{authorize-key?} (default: @code{#t}) +Whether to authorize the substitute key for @code{hydra.gnu.org} +(@pxref{Substitutes}). + +@item @code{use-substitutes?} (default: @code{#t}) +Whether to use substitutes. + +@item @code{extra-options} (default: @code{'()}) +List of extra command-line options for @command{guix-daemon}. + +@item @code{lsof} (default: @var{lsof}) +@itemx @code{lsh} (default: @var{lsh}) +The lsof and lsh packages to use. + +@end table +@end deftp + +@deffn {Scheme Procedure} guix-service @var{config} +Return a service that runs the Guix build daemon according to +@var{config}. @end deffn -@deffn {Monadic Procedure} udev-service [#:udev udev] +@deffn {Scheme Procedure} udev-service [#:udev udev] Run @var{udev}, which populates the @file{/dev} directory dynamically. @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 @command{loadkeys} command. @end deffn @@ -5897,12 +5983,12 @@ The @code{(gnu services networking)} module provides services to configure the network interface. @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 Protocol (DHCP) client, on all the non-loopback network interfaces. @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{'()}] 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 @@ -5910,12 +5996,12 @@ gateway. @end deffn @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 network manager that aims to simplify wired and wireless networking. @end deffn -@deffn {Monadic Procedure} ntp-service [#:ntp @var{ntp}] @ +@deffn {Scheme Procedure} ntp-service [#:ntp @var{ntp}] @ [#:name-service @var{%ntp-servers}] Return a service that runs the daemon from @var{ntp}, the @uref{http://www.ntp.org, Network Time Protocol package}. The daemon will @@ -5926,14 +6012,14 @@ keep the system clock synchronized with that of @var{servers}. List of host names used as the default NTP servers. @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. The daemon runs with the default settings (in particular the default exit policy) as the @code{tor} unprivileged user. @end deffn -@deffn {Monadic Procedure} bitlbee-service [#:bitlbee bitlbee] @ +@deffn {Scheme Procedure} bitlbee-service [#:bitlbee bitlbee] @ [#:interface "127.0.0.1"] [#:port 6667] @ [#:extra-settings ""] Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that @@ -5950,7 +6036,7 @@ configuration file. 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] @ [#:allow-empty-passwords? #f] [#:root-login? #f] @ [#:syslog-output? #t] [#:x11-forwarding? #t] @ @@ -6017,7 +6103,7 @@ browsers, from accessing Facebook. 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] @ [#:ipv6? #t] [#:wide-area? #f] @ [#:domains-to-browse '()] @@ -6047,7 +6133,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 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] @ [#:theme @var{%default-slim-theme}] @ [#:theme-name @var{%default-slim-theme-name}] @@ -6083,7 +6169,7 @@ theme. The G-Expression denoting the default SLiM theme and its name. @end defvr -@deffn {Monadic Procedure} xorg-start-command [#:guile] @ +@deffn {Scheme Procedure} xorg-start-command [#:guile] @ [#:configuration-file #f] [#:xorg-server @var{xorg-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 @@ -6093,7 +6179,7 @@ file or a derivation that builds it; when omitted, the result of Usually the X server is started by a login manager. @end deffn -@deffn {Monadic Procedure} xorg-configuration-file @ +@deffn {Scheme Procedure} xorg-configuration-file @ [#:drivers '()] [#:resolutions '()] [#:extra-config '()] Return a configuration file for the Xorg server containing search paths for all the common drivers. @@ -6141,11 +6227,10 @@ The @var{%desktop-services} variable can be used as the @code{services} field of an @code{operating-system} declaration (@pxref{operating-system Reference, @code{services}}). -The actual service definitions provided by @code{(gnu services desktop)} -are described below. +The actual service definitions provided by @code{(gnu services dbus)} +and @code{(gnu services desktop)} are described below. -@deffn {Monadic Procedure} dbus-service @var{services} @ - [#:dbus @var{dbus}] +@deffn {Scheme Procedure} dbus-service [#:dbus @var{dbus}] [#:services '()] Return a service that runs the ``system bus'', using @var{dbus}, with support for @var{services}. @@ -6159,8 +6244,7 @@ and policy files. For example, to allow avahi-daemon to use the system bus, @var{services} must be equal to @code{(list avahi)}. @end deffn -@deffn {Monadic Procedure} elogind-service @ - [#:elogind @var{elogind}] [#:config @var{config}] +@deffn {Scheme Procedure} elogind-service [#:config @var{config}] Return a service that runs the @code{elogind} login and seat management daemon. @uref{https://github.com/andywingo/elogind, Elogind} exposes a D-Bus interface that can be used to know which users @@ -6230,7 +6314,7 @@ their default values are: @end table @end deffn -@deffn {Monadic Procedure} polkit-service @ +@deffn {Scheme Procedure} polkit-service @ [#:polkit @var{polkit}] Return a service that runs the Polkit privilege manager. @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit} allows @@ -6240,7 +6324,7 @@ whose session is active to shut down the machine, if there are no other users active. @end deffn -@deffn {Monadic Procedure} upower-service [#:upower @var{upower}] @ +@deffn {Scheme Procedure} upower-service [#:upower @var{upower}] @ [#:watts-up-pro? #f] @ [#:poll-batteries? #t] @ [#:ignore-lid? #f] @ @@ -6259,7 +6343,7 @@ levels, with the given configuration settings. It implements the GNOME. @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 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 @@ -6287,7 +6371,7 @@ Firefox and Epiphany both query the user before allowing a web page to know the user's location. @end defvr -@deffn {Monadic Procedure} geoclue-service [#:colord @var{colord}] @ +@deffn {Scheme Procedure} geoclue-service [#:colord @var{colord}] @ [#:whitelist '()] @ [#:wifi-geolocation-url "https://location.services.mozilla.com/v1/geolocate?key=geoclue"] @ [#:submit-data? #f] @@ -6307,7 +6391,7 @@ web site} for more information. 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''] Return a service that runs @var{postgresql}, the PostgreSQL database server. @@ -6322,7 +6406,7 @@ The PostgreSQL daemon loads its runtime configuration from 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''] @ [#:run-directory ``/var/run/nginx''] @ [#:config-file] @@ -6342,7 +6426,7 @@ directories are created when the service is activated. 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] @ [#:extra-options '()] Return a service that runs @url{http://www.lirc.org,LIRC}, a daemon that @@ -6515,13 +6599,11 @@ configuration file: (define %my-base-services ;; Replace the default nscd service with one that knows ;; about nss-mdns. - (map (lambda (mservice) - ;; "Bind" the MSERVICE monadic value to inspect it. - (mlet %store-monad ((service mservice)) - (if (member 'nscd (service-provision service)) - (nscd-service (nscd-configuration) - #:name-services (list nss-mdns)) - mservice))) + (map (lambda (service) + (if (member 'nscd (service-provision service)) + (nscd-service (nscd-configuration + (name-services (list nss-mdns)))) + service)) %base-services)) @end example @@ -6880,6 +6962,11 @@ using the following command: Attempt to build for @var{system} instead of the host's system type. This works as per @command{guix build} (@pxref{Invoking guix build}). +@item --derivation +@itemx -d +Return the derivation file name of the given operating system without +building anything. + @item --image-size=@var{size} For the @code{vm-image} and @code{disk-image} actions, create an image of the given @var{size}. @var{size} may be a number of bytes, or it may @@ -6916,54 +7003,378 @@ build users. @node Defining Services @subsection Defining Services -The @code{(gnu services @dots{})} modules define several procedures that allow -users to declare the operating system's services (@pxref{Using the -Configuration System}). These procedures are @emph{monadic -procedures}---i.e., procedures that return a monadic value in the store -monad (@pxref{The Store Monad}). For examples of such procedures, -@xref{Services}. - -@cindex service definition -The monadic value returned by those procedures is a @dfn{service -definition}---a structure as returned by the @code{service} form. -Service definitions specifies the inputs the service depends on, and an -expression to start and stop the service. Behind the scenes, service -definitions are ``translated'' into the form suitable for the -configuration file of dmd, the init system (@pxref{Services,,, dmd, GNU -dmd Manual}). - -As an example, here is what the @code{nscd-service} procedure looks -like: +The previous sections show the available services and how one can combine +them in an @code{operating-system} declaration. But how do we define +them in the first place? And what is a service anyway? -@lisp -(define (nscd-service) - (with-monad %store-monad - (return (service - (documentation "Run libc's name service cache daemon.") - (provision '(nscd)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/nscd"))) - (start #~(make-forkexec-constructor - (string-append #$glibc "/sbin/nscd") - "-f" "/dev/null" "--foreground")) - (stop #~(make-kill-destructor)) - (respawn? #f))))) -@end lisp +@menu +* Service Composition:: The model for composing services. +* Service Types and Services:: Types and services. +* Service Reference:: API reference. +* dmd Services:: A particular type of service. +@end menu + +@node Service Composition +@subsubsection Service Composition + +@cindex services +@cindex daemons +Here we define a @dfn{service} as, broadly, something that extends the +operating system's functionality. Often a service is a process---a +@dfn{daemon}---started when the system boots: a secure shell server, a +Web server, the Guix build daemon, etc. Sometimes a service is a daemon +whose execution can be triggered by another daemon---e.g., an FTP server +started by @command{inetd} or a D-Bus service activated by +@command{dbus-daemon}. Occasionally, a service does not map to a +daemon. For instance, the ``account'' service collects user accounts +and makes sure they exist when the system runs; the ``udev'' service +collects device management rules and makes them available to the eudev +daemon; the @file{/etc} service populates the system's @file{/etc} +directory. + +GuixSD services are connected by @dfn{extensions}. For instance, the +secure shell service @emph{extends} dmd---GuixSD's initialization system, +running as PID@tie{}1---by giving it the command lines to start and stop +the secure shell daemon (@pxref{Networking Services, +@code{lsh-service}}); the UPower service extends the D-Bus service by +passing it its @file{.service} specification, and extends the udev +service by passing it device management rules (@pxref{Desktop Services, +@code{upower-service}}); the Guix daemon service extends dmd by passing +it the command lines to start and stop the daemon, and extends the +account service by passing it a list of required build user accounts +(@pxref{Base Services}). + +All in all, services and their ``extends'' relations form a directed +acyclic graph (DAG). If we represent services as boxes and extensions +as arrows, a typical system might provide something like this: + +@image{images/service-graph,,5in,Typical service extension graph.} + +At the bottom, we see the @dfn{boot service}, which produces the boot +script that is executed at boot time from the initial RAM disk. + +@cindex service types +Technically, developers can define @dfn{service types} to express these +relations. There can be any number of services of a given type on the +system---for instance, a system running two instances of the GNU secure +shell server (lsh) has two instances of @var{lsh-service-type}, with +different parameters. + +The following section describes the programming interface for service +types and services. + +@node Service Types and Services +@subsubsection Service Types and Services + +A @dfn{service type} is a node in the DAG described above. Let us start +with a simple example, the service type for the Guix build daemon +(@pxref{Invoking guix-daemon}): + +@example +(define guix-service-type + (service-type + (name 'guix) + (extensions + (list (service-extension dmd-root-service-type guix-dmd-service) + (service-extension account-service-type guix-accounts) + (service-extension activation-service-type guix-activation))))) +@end example @noindent -The @code{activate}, @code{start}, and @code{stop} fields are G-expressions -(@pxref{G-Expressions}). The @code{activate} field contains a script to -run at ``activation'' time; it makes sure that the @file{/var/run/nscd} -directory exists before @command{nscd} is started. +It defines a two things: + +@enumerate +@item +A name, whose sole purpose is to make inspection and debugging easier. + +@item +A list of @dfn{service extensions}, where each extension designates the +target service type and a procedure that, given the service's +parameters, returns a list of object to extend the service of that type. + +Every service type has at least one service extension. The only +exception is the @dfn{boot service type}, which is the ultimate service. +@end enumerate + +In this example, @var{guix-service-type} extends three services: + +@table @var +@item dmd-root-service-type +The @var{guix-dmd-service} procedure defines how the dmd service is +extended. Namely, it returns a @code{<dmd-service>} object that defines +how @command{guix-daemon} is started and stopped (@pxref{dmd Services}). + +@item account-service-type +This extension for this service is computed by @var{guix-accounts}, +which returns a list of @code{user-group} and @code{user-account} +objects representing the build user accounts (@pxref{Invoking +guix-daemon}). + +@item activation-service-type +Here @var{guix-activation} is a procedure that returns a gexp, which is +a code snippet to run at ``activation time''---e.g., when the service is +booted. +@end table + +A service of this type is instantiated like this: + +@example +(service guix-service-type + (guix-configuration + (build-accounts 5) + (use-substitutes? #f))) +@end example + +The second argument to the @code{service} form is a value representing +the parameters of this specific service instance. +@xref{guix-configuration-type, @code{guix-configuration}}, for +information about the @code{guix-configuration} data type. + +@var{guix-service-type} is quite simple because it extends other +services but is not extensible itself. + +@c @subsubsubsection Extensible Service Types + +The service type for an @emph{extensible} service looks like this: + +@example +(define udev-service-type + (service-type (name 'udev) + (extensions + (list (service-extension dmd-root-service-type + udev-dmd-service))) + + (compose concatenate) ;concatenate the list of rules + (extend (lambda (config rules) + (match config + (($ <udev-configuration> udev initial-rules) + (udev-configuration + (udev udev) ;the udev package to use + (rules (append initial-rules rules))))))))) +@end example +This is the service type for the +@uref{https://wiki.gentoo.org/wiki/Project:Eudev, eudev device +management daemon}. Compared to the previous example, in addition to an +extension of @var{dmd-root-service-type}, we see two new fields: + +@table @code +@item compose +This is the procedure to @dfn{compose} the list of extensions to +services of this type. + +Services can extend the udev service by passing it lists of rules; we +compose those extensions simply by concatenating them. + +@item extend +This procedure defines how the service's value is @dfn{extended} with +the composition of the extensions. + +Udev extensions are composed into a list of rules, but the udev service +value is itself a @code{<udev-configuration>} record. So here, we +extend that record by appending the list of rules is contains to the +list of contributed rules. +@end table + +There can be only one instance of an extensible service type such as +@var{udev-service-type}. If there were more, the +@code{service-extension} specifications would be ambiguous. + +Still here? The next section provides a reference of the programming +interface for services. + +@node Service Reference +@subsubsection Service Reference + +We have seen an overview of service types (@pxref{Service Types and +Services}). This section provides a reference on how to manipulate +services and service types. This interface is provided by the +@code{(gnu services)} module. + +@deffn {Scheme Procedure} service @var{type} @var{value} +Return a new service of @var{type}, a @code{<service-type>} object (see +below.) @var{value} can be any object; it represents the parameters of +this particular service instance. +@end deffn + +@deffn {Scheme Procedure} service? @var{obj} +Return true if @var{obj} is a service. +@end deffn + +@deffn {Scheme Procedure} service-kind @var{service} +Return the type of @var{service}---i.e., a @code{<service-type>} object. +@end deffn + +@deffn {Scheme Procedure} service-parameters @var{service} +Return the value associated with @var{service}. It represents its +parameters. +@end deffn + +Here is an example of how a service is created and manipulated: + +@example +(define s + (service nginx-service-type + (nginx-configuration + (nginx nginx) + (log-directory log-directory) + (run-directory run-directory) + (file config-file)))) + +(service? s) +@result{} #t + +(eq? (service-kind s) nginx-service-type) +@result{} #t +@end example + +@deftp {Data Type} service-type +@cindex service type +This is the representation of a @dfn{service type} (@pxref{Service Types +and Services}). + +@table @asis +@item @code{name} +This is a symbol, used only to simplify inspection and debugging. + +@item @code{extensions} +A non-empty list of @code{<service-extension>} objects (see below.) + +@item @code{compose} (default: @code{#f}) +If this is @code{#f}, then the service type denotes services that cannot +be extended---i.e., services that do not receive ``values'' from other +services. + +Otherwise, it must be a one-argument procedure. The procedure is called +by @code{fold-services} and is passed a list of values collected from +extensions. It must return a value that is a valid parameter value for +the service instance. + +@item @code{extend} (default: @code{#f}) +If this is @code{#f}, services of this type cannot be extended. + +Otherwise, it must be a two-argument procedure: @code{fold-services} +calls it, passing it the service's initial value as the first argument +and the result of applying @code{compose} to the extension values as the +second argument. +@end table + +@xref{Service Types and Services}, for examples. +@end deftp + +@deffn {Scheme Procedure} service-extension @var{target-type} @ + @var{compute} +Return a new extension for services of type @var{target-type}. +@var{compute} must be a one-argument procedure: @code{fold-services} +calls it, passing it the value associated with the service that provides +the extension; it must return a valid value for the target service. +@end deffn + +@deffn {Scheme Procedure} service-extension? @var{obj} +Return true if @var{obj} is a service extension. +@end deffn + +At the core of the service abstraction lies the @code{fold-services} +procedure, which is responsible for ``compiling'' a list of services +down to a single boot script. In essence, it propagates service +extensions down the service graph, updating each node parameters on the +way, until it reaches the root node. + +@deffn {Scheme Procedure} fold-services @var{services} @ + [#:target-type @var{boot-service-type}] +Fold @var{services} by propagating their extensions down to the root of +type @var{target-type}; return the root service adjusted accordingly. +@end deffn + +Lastly, the @code{(gnu services)} module also defines several essential +service types, some of which are listed below. + +@defvr {Scheme Variable} boot-service-type +The type of the ``boot service'', which is the root of the service +graph. +@end defvr + +@defvr {Scheme Variable} etc-service-type +The type of the @file{/etc} service. This service can be extended by +passing it name/file tuples such as: + +@example +(list `("issue" ,(plain-file "issue" "Welcome!\n"))) +@end example + +In this example, the effect would be to add an @file{/etc/issue} file +pointing to the given file. +@end defvr + +@defvr {Scheme Variable} setuid-program-service-type +Type for the ``setuid-program service''. This service collects lists of +executable file names, passed as gexps, and adds them to the set of +setuid-root programs on the system (@pxref{Setuid Programs}). +@end defvr + + +@node dmd Services +@subsubsection dmd Services + +@cindex PID 1 +@cindex init system +The @code{(gnu services dmd)} provides a way to define services managed +by GNU@tie{}dmd, which is GuixSD initialization system---the first +process that is started when the system boots, aka. PID@tie{}1 +(@pxref{Introduction,,, dmd, GNU dmd Manual}). The +@var{%dmd-root-service} represents PID@tie{}1, of type +@var{dmd-root-service-type}; it can be extended by passing it lists of +@code{<dmd-service>} objects. + +@deftp {Data Type} dmd-service +The data type representing a service managed by dmd. + +@table @asis +@item @code{provision} +This is a list of symbols denoting what the service provides. + +These are the names that may be passed to @command{deco start}, +@command{deco status}, and similar commands (@pxref{Invoking deco,,, +dmd, GNU dmd Manual}). @xref{Slots of services, the @code{provides} +slot,, dmd, GNU dmd Manual}, for details. + +@item @code{requirements} (default: @code{'()}) +List of symbols denoting the dmd services this one depends on. + +@item @code{respawn?} (default: @code{#t}) +Whether to restart the service when it stops, for instance when the +underlying process dies. + +@item @code{start} +@itemx @code{stop} (default: @code{#~(const #f)}) The @code{start} and @code{stop} fields refer to dmd's facilities to start and stop processes (@pxref{Service De- and Constructors,,, dmd, -GNU dmd Manual}). The @code{provision} field specifies the name under -which this service is known to dmd, and @code{documentation} specifies -on-line documentation. Thus, the commands @command{deco start ncsd}, -@command{deco stop nscd}, and @command{deco doc nscd} will do what you -would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}). +GNU dmd Manual}). They are given as G-expressions that get expanded in +the dmd configuration file (@pxref{G-Expressions}). + +@item @code{documentation} +A documentation string, as shown when running: + +@example +deco doc @var{service-name} +@end example + +where @var{service-name} is one of the symbols in @var{provision} +(@pxref{Invoking deco,,, dmd, GNU dmd Manual}). +@end table +@end deftp + +@defvr {Scheme Variable} dmd-root-service-type +The service type for the dmd ``root service''---i.e., PID@tie{}1. + +This is the service type that extensions target when they want to create +dmd services (@pxref{Service Types and Services}, for an example). Each +extension must pass a list of @code{<dmd-service>}. +@end defvr + +@defvr {Scheme Variable} %dmd-root-service +This service represents PID@tie{}1. +@end defvr @node Installing Debugging Files diff --git a/doc/images/service-graph.dot b/doc/images/service-graph.dot new file mode 100644 index 0000000000..3397b878e9 --- /dev/null +++ b/doc/images/service-graph.dot @@ -0,0 +1,35 @@ +digraph "Service Type Dependencies" { + dmd [shape = box, fontname = Helvetica]; + pam [shape = box, fontname = Helvetica]; + etc [shape = box, fontname = Helvetica]; + accounts [shape = box, fontname = Helvetica]; + activation [shape = box, fontname = Helvetica]; + boot [shape = house, fontname = Helvetica]; + lshd -> dmd; + lshd -> pam; + udev -> dmd; + nscd -> dmd [label = "extends"]; + "nss-mdns" -> nscd; + "kvm-rules" -> udev; + colord -> udev; + dbus -> dmd; + colord -> dbus; + upower -> udev; + upower -> dbus; + polkit -> dbus; + polkit -> pam; + elogind -> dbus; + elogind -> udev; + elogind -> polkit [label = "extends"]; + dmd -> boot; + colord -> accounts; + accounts -> activation; + accounts -> etc; + etc -> activation; + activation -> boot; + pam -> etc; + elogind -> pam; + guix -> dmd; + guix -> activation; + guix -> accounts; +} diff --git a/emacs/guix-build-log.el b/emacs/guix-build-log.el index 9ce30bd1dd..c0855b284c 100644 --- a/emacs/guix-build-log.el +++ b/emacs/guix-build-log.el @@ -256,8 +256,9 @@ Return nil, if there is no phase start before the current point." ;; Some phases may be hidden, and some shown. Whether to hide or to ;; show them, it is determined by the state of the first phase here. (goto-char (point-min)) - (guix-build-log-next-phase) - (let ((fun (guix-build-log-phase-toggle-function))) + (let ((fun (save-excursion + (re-search-forward guix-build-log-phase-start-regexp nil t) + (guix-build-log-phase-toggle-function)))) (while (re-search-forward guix-build-log-phase-start-regexp nil t) (funcall fun))))) diff --git a/emacs/guix-devel.el b/emacs/guix-devel.el index 8a6fc1ec08..b8330289c5 100644 --- a/emacs/guix-devel.el +++ b/emacs/guix-devel.el @@ -43,6 +43,12 @@ "Face for a `modify-phases' keyword ('delete', 'replace', etc.)." :group 'guix-devel-faces) +(defface guix-devel-gexp-symbol + '((t :inherit font-lock-keyword-face)) + "Face for gexp symbols ('#~', '#$', etc.). +See Info node `(guix) G-Expressions'." + :group 'guix-devel-faces) + (defcustom guix-devel-activate-mode t "If non-nil, then `guix-devel-mode' is automatically activated in Scheme buffers." @@ -70,11 +76,14 @@ Interactively, use the module defined by the current scheme file." "Setup REPL for using `guix-devel-...' commands." (guix-devel-use-modules "(guix monad-repl)" "(guix scripts)" - "(guix store)") - ;; Without this workaround, the build output disappears. See + "(guix store)" + "(guix ui)") + ;; Without this workaround, the warning/build output disappears. See ;; <https://github.com/jaor/geiser/issues/83> for details. - (guix-geiser-eval-in-repl - "(current-build-output-port (current-error-port))" + (guix-geiser-eval-in-repl-synchronously + "(begin + (guix-warning-port (current-warning-port)) + (current-build-output-port (current-error-port)))" repl 'no-history 'no-display)) (defvar guix-devel-repl-processes nil @@ -88,12 +97,21 @@ Interactively, use the module defined by the current scheme file." (guix-devel-setup-repl repl) (push process guix-devel-repl-processes)))) +(defmacro guix-devel-with-definition (def-var &rest body) + "Run BODY with the current guile definition bound to DEF-VAR. +Bind DEF-VAR variable to the name of the current top-level +definition, setup the current REPL, use the current module, and +run BODY." + (declare (indent 1) (debug (symbolp body))) + `(let ((,def-var (guix-guile-current-definition))) + (guix-devel-setup-repl-maybe) + (guix-devel-use-modules (guix-guile-current-module)) + ,@body)) + (defun guix-devel-build-package-definition () "Build a package defined by the current top-level variable definition." (interactive) - (let ((def (guix-guile-current-definition))) - (guix-devel-setup-repl-maybe) - (guix-devel-use-modules (guix-guile-current-module)) + (guix-devel-with-definition def (when (or (not guix-operation-confirm) (guix-operation-prompt (format "Build '%s'?" def))) (guix-geiser-eval-in-repl @@ -104,6 +122,32 @@ Interactively, use the module defined by the current scheme file." guix-use-substitutes) "#:dry-run?" (guix-guile-boolean guix-dry-run))))))) +(defun guix-devel-build-package-source () + "Build the source of the current package definition." + (interactive) + (guix-devel-with-definition def + (when (or (not guix-operation-confirm) + (guix-operation-prompt + (format "Build '%s' package source?" def))) + (guix-geiser-eval-in-repl + (concat ",run-in-store " + (guix-guile-make-call-expression + "build-package-source" def + "#:use-substitutes?" (guix-guile-boolean + guix-use-substitutes) + "#:dry-run?" (guix-guile-boolean guix-dry-run))))))) + +(defun guix-devel-lint-package () + "Check the current package. +See Info node `(guix) Invoking guix lint' for details." + (interactive) + (guix-devel-with-definition def + (guix-devel-use-modules "(guix scripts lint)") + (when (or (not guix-operation-confirm) + (y-or-n-p (format "Lint '%s' package?" def))) + (guix-geiser-eval-in-repl + (format "(run-checkers %s)" def))))) + ;;; Font-lock @@ -126,11 +170,17 @@ This function is used as a MATCHER for `font-lock-keywords'." "Skip the next sexp, and return the end point of the current list. This function is used as a PRE-MATCH-FORM for `font-lock-keywords' to find 'modify-phases' keywords." - (ignore-errors (forward-sexp)) - (save-excursion (up-list) (point))) + (let ((in-comment? (nth 4 (syntax-ppss)))) + ;; If 'modify-phases' is commented, do not try to search for its + ;; keywords. + (unless in-comment? + (ignore-errors (forward-sexp)) + (save-excursion (up-list) (point))))) (defvar guix-devel-font-lock-keywords - `((,(guix-guile-keyword-regexp "modify-phases") + `((,(rx (or "#~" "#$" "#$@" "#+" "#+@")) . + 'guix-devel-gexp-symbol) + (,(guix-guile-keyword-regexp "modify-phases") (1 'font-lock-keyword-face) (guix-devel-modify-phases-font-lock-matcher (guix-devel-modify-phases-font-lock-pre) @@ -142,6 +192,8 @@ to find 'modify-phases' keywords." (defvar guix-devel-keys-map (let ((map (make-sparse-keymap))) (define-key map (kbd "b") 'guix-devel-build-package-definition) + (define-key map (kbd "s") 'guix-devel-build-package-source) + (define-key map (kbd "l") 'guix-devel-lint-package) (define-key map (kbd "k") 'guix-devel-copy-module-as-kill) (define-key map (kbd "u") 'guix-devel-use-module) map) @@ -184,6 +236,14 @@ bindings: (when guix-devel-activate-mode (guix-devel-mode))) + +(defvar guix-devel-emacs-font-lock-keywords + (eval-when-compile + `((,(rx "(" (group "guix-devel-with-definition") symbol-end) . 1)))) + +(font-lock-add-keywords 'emacs-lisp-mode + guix-devel-emacs-font-lock-keywords) + (provide 'guix-devel) ;;; guix-devel.el ends here diff --git a/emacs/guix-geiser.el b/emacs/guix-geiser.el index eb449bcdb1..0e6cc03a84 100644 --- a/emacs/guix-geiser.el +++ b/emacs/guix-geiser.el @@ -80,6 +80,23 @@ If NO-DISPLAY is non-nil, do not switch to the REPL buffer." (unless no-display (geiser-repl--switch-to-buffer repl)))) +(defun guix-geiser-eval-in-repl-synchronously (str &optional repl + no-history no-display) + "Evaluate STR in Geiser REPL synchronously, i.e. wait until the +REPL operation will be finished. +See `guix-geiser-eval-in-repl' for the meaning of arguments." + (let* ((repl (if repl (get-buffer repl) (guix-geiser-repl))) + (running? nil) + (filter (lambda (output) + (setq running? + (and (get-buffer-process repl) + (not (guix-guile-prompt? output)))))) + (comint-output-filter-functions + (cons filter comint-output-filter-functions))) + (guix-geiser-eval-in-repl str repl no-history no-display) + (while running? + (sleep-for 0.1)))) + (defun guix-geiser-call (proc &rest args) "Call (PROC ARGS ...) synchronously using the current Geiser REPL. PROC and ARGS should be strings." diff --git a/emacs/guix-guile.el b/emacs/guix-guile.el index 63322d7ed8..cd6c54d87e 100644 --- a/emacs/guix-guile.el +++ b/emacs/guix-guile.el @@ -88,6 +88,11 @@ PROC and ARGS should be strings." args " "))) +(defun guix-guile-prompt? (string) + "Return non-nil, if STRING contains a Guile prompt." + (or (string-match-p geiser-guile--prompt-regexp string) + (string-match-p geiser-guile--debugger-prompt-regexp string))) + (provide 'guix-guile) ;;; guix-guile.el ends here diff --git a/gnu-system.am b/gnu-system.am index 2912305c92..35b3235005 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -348,6 +348,7 @@ GNU_SYSTEM_MODULES = \ gnu/services/avahi.scm \ gnu/services/base.scm \ gnu/services/databases.scm \ + gnu/services/dbus.scm \ gnu/services/desktop.scm \ gnu/services/dmd.scm \ gnu/services/lirc.scm \ @@ -561,6 +562,8 @@ dist_patch_DATA = \ gnu/packages/patches/luit-posix.patch \ gnu/packages/patches/m4-gets-undeclared.patch \ gnu/packages/patches/make-impure-dirs.patch \ + gnu/packages/patches/mars-install.patch \ + gnu/packages/patches/mars-sfml-2.3.patch \ gnu/packages/patches/maxima-defsystem-mkdir.patch \ gnu/packages/patches/mc-fix-ncurses-build.patch \ gnu/packages/patches/mcron-install.patch \ diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 95220d0bc0..e911494058 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -36,7 +36,9 @@ "Apply THUNK, but exit with a status code of 1 if it fails." (dynamic-wind (const #t) - thunk + (lambda () + (thunk) + (primitive-exit 0)) (lambda () (primitive-exit 1)))) diff --git a/gnu/packages/bioinformatics.scm b/gnu/packages/bioinformatics.scm index 0e0a886cc0..4b7f76b9c6 100644 --- a/gnu/packages/bioinformatics.scm +++ b/gnu/packages/bioinformatics.scm @@ -617,6 +617,9 @@ gapped, local, and paired-end alignment modes.") ;; no "configure" script (alist-delete 'configure %standard-phases)))) (inputs `(("zlib" ,zlib))) + ;; Non-portable SSE instructions are used so building fails on platforms + ;; other than x86_64. + (supported-systems '("x86_64-linux")) (home-page "http://bio-bwa.sourceforge.net/") (synopsis "Burrows-Wheeler sequence aligner") (description diff --git a/gnu/packages/game-development.scm b/gnu/packages/game-development.scm index e8efc2c5a3..fcebf2b548 100644 --- a/gnu/packages/game-development.scm +++ b/gnu/packages/game-development.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Julian Graham <joolean@gmail.com> ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,7 @@ #:use-module (guix build-system gnu) #:use-module (gnu packages) #:use-module (gnu packages databases) + #:use-module (gnu packages doxygen) #:use-module (gnu packages glib) #:use-module (gnu packages gnunet) #:use-module (gnu packages guile) @@ -225,3 +227,36 @@ Originally created for use in video game prototypes, it can generate random sounds from presets such as \"explosion\" or \"powerup\".") (home-page "http://www.drpetter.se/project_sfxr.html") (license license:expat))) + +(define-public physfs + (package + (name "physfs") + (version "2.0.3") + (source (origin + (method url-fetch) + (uri (string-append + "http://icculus.org/physfs/downloads/physfs-" + version ".tar.bz2")) + (file-name (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + "0sbbyqzqhyf0g68fcvvv20n3928j0x6ik1njmhn1yigvq2bj11na")))) + (build-system cmake-build-system) + (arguments + '(#:tests? #f)) ; no check target + (inputs + `(("zlib" ,zlib))) + (native-inputs + `(("doxygen" ,doxygen))) + (home-page "http://icculus.org/physfs") + (synopsis "File system abstraction library") + (description + "PhysicsFS is a library to provide abstract access to various archives. +It is intended for use in video games. For security, no file writing done +through the PhysicsFS API can leave a defined @emph{write directory}. For +file reading, a @emph{search path} with archives and directories is defined, +and it becomes a single, transparent hierarchical file system. So archive +files can be accessed in the same way as you access files directly on a disk, +and it makes it easy to ship a new archive that will override a previous +archive on a per-file basis.") + (license license:zlib))) diff --git a/gnu/packages/games.scm b/gnu/packages/games.scm index 7eb65bb23b..3f1f5a9c94 100644 --- a/gnu/packages/games.scm +++ b/gnu/packages/games.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2015 David Hashe <david.hashe@dhashe.com> ;;; Copyright © 2015 Christopher Allan Webber <cwebber@dustycloud.org> +;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,11 +32,14 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix download) + #:use-module (guix git-download) #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages admin) #:use-module (gnu packages audio) #:use-module (gnu packages boost) + #:use-module (gnu packages fribidi) + #:use-module (gnu packages game-development) #:use-module (gnu packages gettext) #:use-module (gnu packages gl) #:use-module (gnu packages glib) @@ -44,6 +48,7 @@ #:use-module (gnu packages guile) #:use-module (gnu packages libcanberra) #:use-module (gnu packages libunwind) + #:use-module (gnu packages mp3) #:use-module (gnu packages image) #:use-module (gnu packages ncurses) #:use-module (gnu packages python) @@ -573,6 +578,59 @@ for common mesh file formats, and collision detection.") (home-page "http://irrlicht.sourceforge.net/") (license license:zlib))) +(define-public mars + ;; The latest release on SourceForge relies on an unreleased version of SFML + ;; with a different API, so we take the latest version from the official + ;; repository on Github. + (let ((commit "c855d04409") + (revision "1")) + (package + (name "mars") + (version (string-append "0.7.5." revision "." commit )) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/thelaui/M.A.R.S..git") + (commit commit))) + (file-name (string-append name "-" version)) + (sha256 + (base32 + "1r4c5gap1z2zsv4yjd34qriqkxaq4lb4rykapyzkkdf4g36lc3nh")) + (patches (list (search-patch "mars-sfml-2.3.patch") + (search-patch "mars-install.patch"))))) + (build-system cmake-build-system) + (arguments + `(#:tests? #f ; There are no tests + #:phases + (modify-phases %standard-phases + (add-after 'unpack 'fix-install-path + (lambda _ + (substitute* "src/CMakeLists.txt" + (("\\$\\{CMAKE_INSTALL_PREFIX\\}/games") + "${CMAKE_INSTALL_PREFIX}/bin")) + #t)) + (add-after 'unpack 'fix-data-path + (lambda* (#:key outputs #:allow-other-keys) + (substitute* "src/System/settings.cpp" + (("C_dataPath = \"./data/\";") + (string-append "C_dataPath = \"" + (assoc-ref outputs "out") + "/share/games/marsshooter/\";"))) + #t))))) + (inputs + `(("mesa" ,mesa) + ("fribidi" ,fribidi) + ("taglib" ,taglib) + ("sfml" ,sfml))) + (home-page "http://marsshooter.org") + (synopsis "2D space shooter") + (description + "M.A.R.S. is a 2D space shooter with pretty visual effects and +attractive physics. Players can battle each other or computer controlled +enemies in different game modes such as space ball, death match, team death +match, cannon keep, and grave-itation pit.") + (license license:gpl3+)))) + (define minetest-data (package (name "minetest-data") diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm index 3bd87dccc6..333e88362b 100644 --- a/gnu/packages/gnupg.scm +++ b/gnu/packages/gnupg.scm @@ -193,14 +193,14 @@ compatible to GNU Pth.") (define-public gnupg (package (name "gnupg") - (version "2.1.8") + (version "2.1.9") (source (origin (method url-fetch) (uri (string-append "mirror://gnupg/gnupg/gnupg-" version ".tar.bz2")) (sha256 (base32 - "18w14xp0ynzzwpklyplkzbrncds1hly4k2gjx115swch8qgd1f53")))) + "1dpp555glln6fldk72ad7lkrn8h3cr2bg714z5kfn2qrawx67dqw")))) (build-system gnu-build-system) (native-inputs `(("pkg-config" ,pkg-config))) diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm index f77c9dfece..e778bf0f6e 100644 --- a/gnu/packages/guile.scm +++ b/gnu/packages/guile.scm @@ -39,6 +39,7 @@ #:use-module (gnu packages texinfo) #:use-module (gnu packages gettext) #:use-module (gnu packages gdbm) + #:use-module (gnu packages python) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix git-download) @@ -592,4 +593,80 @@ interface for reading articles in any format.") key-value cache and store.") (license lgpl3+))) +(define-public guile-wisp + (package + (name "guile-wisp") + (version "0.9.0") + (source (origin + (method url-fetch) + (uri (string-append "https://bitbucket.org/ArneBab/" + "wisp/downloads/wisp-" + version ".tar.gz")) + (sha256 + (base32 + "0y5fxacalkgbv9s71h58vdvm2h2ln3rk024dd0vszwcf953as5fq")))) + (build-system gnu-build-system) + (arguments + `(#:modules ((system base compile) + ,@%gnu-build-system-modules) + #:phases + (modify-phases %standard-phases + (add-before + 'configure 'substitute-before-config + + (lambda* (#:key inputs #:allow-other-keys) + (let ((bash (assoc-ref inputs "bash"))) + ;; configure checks for guile-2.0, but ours is just named "guile" :) + (substitute* "configure" + (("guile-2.0") "guile")) + ;; Puts together some test files with /bin/bash hardcoded + (substitute* "Makefile.in" + (("/bin/bash") + (string-append bash "/bin/bash") )) + #t))) + + ;; auto compilation breaks, but if we set HOME to /tmp, + ;; that works ok + (add-before + 'check 'auto-compile-hacky-workaround + (lambda _ + (setenv "HOME" "/tmp") + #t)) + (replace + 'install + (lambda* (#:key outputs inputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (module-dir (string-append out "/share/guile/site/2.0")) + (language-dir + (string-append module-dir "/language/wisp")) + (guild (string-append (assoc-ref inputs "guile") + "/bin/guild"))) + ;; Make installation directories. + (mkdir-p module-dir) + (mkdir-p language-dir) + + ;; copy the source + (copy-file "wisp-scheme.scm" + (string-append module-dir "/wisp-scheme.scm")) + (copy-file "language/wisp/spec.scm" + (string-append language-dir "/spec.scm")) + + ;; compile to the destination + (compile-file "wisp-scheme.scm" + #:output-file (string-append + module-dir "/wisp-scheme.go")) + (compile-file "language/wisp/spec.scm" + #:output-file (string-append + language-dir "/spec.go")) + #t)))))) + (home-page "http://draketo.de/english/wisp") + (inputs + `(("guile" ,guile-2.0) + ("python" ,python))) + (synopsis "wisp is a whitespace to lisp syntax for Guile") + (description "wisp is a syntax for Guile which provides a Python-like +whitespace-significant language. It may be easier on the eyes for some +users and in some situations.") + (license gpl3+))) + ;;; guile.scm ends here diff --git a/gnu/packages/music.scm b/gnu/packages/music.scm index 78310edf0e..7ee6ca1164 100644 --- a/gnu/packages/music.scm +++ b/gnu/packages/music.scm @@ -206,14 +206,22 @@ you to define complex tempo maps for entire songs or performances.") (assoc-ref %build-inputs "font-tex-gyre") "/share/fonts/opentype/")) #:phases - (alist-cons-before - 'configure 'prepare-configuration - (lambda _ - (substitute* "configure" - (("SHELL=/bin/sh") "SHELL=sh")) - (setenv "out" "") - #t) - %standard-phases))) + (modify-phases %standard-phases + (add-after 'unpack 'hardcode-path-to-gs + (lambda* (#:key inputs #:allow-other-keys) + (substitute* "scm/backend-library.scm" + (("\\(search-executable '\\(\"gs\"\\)\\)") + (string-append "\"" + (assoc-ref inputs "ghostscript") + "/bin/gs" + "\"" ))) + #t)) + (add-before 'configure 'prepare-configuration + (lambda _ + (substitute* "configure" + (("SHELL=/bin/sh") "SHELL=sh")) + (setenv "out" "") + #t))))) (inputs `(("guile" ,guile-1.8) ("font-dejavu" ,font-dejavu) diff --git a/gnu/packages/openstack.scm b/gnu/packages/openstack.scm index 39584d566f..4fd1c803ff 100644 --- a/gnu/packages/openstack.scm +++ b/gnu/packages/openstack.scm @@ -25,6 +25,46 @@ #:select (asl2.0)) #:use-module (guix packages)) +(define-public python-bandit + (package + (name "python-bandit") + (version "0.13.2") + (source + (origin + (method url-fetch) + (uri (string-append + "https://pypi.python.org/packages/source/b/bandit/bandit-" + version ".tar.gz")) + (sha256 + (base32 + "03g3cflvrc99ncjd611iy5nnnscsc2vgnrx4mjaqyx8glbfw8y7g")))) + (build-system python-build-system) + (propagated-inputs + `(("python-appdirs" ,python-appdirs) + ("python-pyyaml" ,python-pyyaml) + ("python-six" ,python-six) + ("python-stevedore" ,python-stevedore))) + (inputs + `(("python-pbr" ,python-pbr) + ("python-setuptools" ,python-setuptools) + ;; Tests + ("python-fixtures" ,python-fixtures) + ("python-mock" ,python-mock) + ("python-testrepository" ,python-testrepository) + ("python-testscenarios" ,python-testscenarios) + ("python-testtools" ,python-testtools))) + (home-page "https://wiki.openstack.org/wiki/Security/Projects/Bandit") + (synopsis "Security oriented static analyser for python code.") + (description + "Bandit is a tool designed to find common security issues in Python code. +To do this Bandit processes each file, builds an AST from it, and runs +appropriate plugins against the AST nodes. Once Bandit has finished scanning +all the files it generates a report.") + (license asl2.0))) + +(define-public python2-bandit + (package-with-python2 python-bandit)) + (define-public python-debtcollector (package (name "python-debtcollector") diff --git a/gnu/packages/patches/mars-install.patch b/gnu/packages/patches/mars-install.patch new file mode 100644 index 0000000000..1e3964c141 --- /dev/null +++ b/gnu/packages/patches/mars-install.patch @@ -0,0 +1,17 @@ +Remove install target for non-existant directory. + +--- a/src/CMakeLists.txt 2015-09-13 20:52:28.517344327 +0200 ++++ b/src/CMakeLists.txt 2015-09-13 20:53:04.842453987 +0200 +@@ -122,12 +122,6 @@ + DESTINATION + ${CMAKE_INSTALL_PREFIX}/share/applications + ) +- install( +- FILES +- ${MARS_SOURCE_DIR}/resources/mars +- DESTINATION +- ${CMAKE_INSTALL_PREFIX}/share/menu +- ) + + else(UNIX) + # executable diff --git a/gnu/packages/patches/mars-sfml-2.3.patch b/gnu/packages/patches/mars-sfml-2.3.patch new file mode 100644 index 0000000000..01ec05ff36 --- /dev/null +++ b/gnu/packages/patches/mars-sfml-2.3.patch @@ -0,0 +1,151 @@ +This is a concatenation of the following two patches: + + https://github.com/jcowgill/M.A.R.S./commit/33d5affabf8ff84f2c028b9303c6a9e83cc824ad.patch + https://patch-diff.githubusercontent.com/raw/thelaui/M.A.R.S./pull/2.patch + +Their purpose is to allow Mars to be built against the latest version of SFML. + +From 33d5affabf8ff84f2c028b9303c6a9e83cc824ad Mon Sep 17 00:00:00 2001 +From: James Cowgill <james410@cowgill.org.uk> +Date: Sat, 9 May 2015 01:54:14 +0100 +Subject: [PATCH] Remove dependency on GLU - fixes build with SFML 2.3 + +--- + premake4.lua | 8 ++++---- + src/Shaders/postFX.cpp | 2 +- + src/System/window.cpp | 12 ++++++------ + 3 files changed, 11 insertions(+), 11 deletions(-) + +diff --git a/premake4.lua b/premake4.lua +index 023dddd..5af4495 100755 +--- a/premake4.lua ++++ b/premake4.lua +@@ -11,11 +11,11 @@ project "mars" + defines { "NDEBUG" }
+ flags { "Optimize" }
+ if os.get() == "windows" then
+- links { "sfml-graphics", "sfml-audio", "sfml-system", "sfml-window", "glu32", "opengl32", "fribidi-0", "tag" }
++ links { "sfml-graphics", "sfml-audio", "sfml-system", "sfml-window", "opengl32", "fribidi-0", "tag" }
+ elseif os.get() == "macosx" then
+ links { "sfml-graphics.framework", "sfml-audio.framework", "sfml-system.framework", "sfml-window.framework", "opengl.framework", "fribidi", "tag" }
+ else
+- links { "GLU", "sfml-graphics", "sfml-audio", "sfml-system", "sfml-window", "fribidi", "tag" }
++ links { "sfml-graphics", "sfml-audio", "sfml-system", "sfml-window", "fribidi", "tag" }
+ libdirs { "/usr/lib", "/usr/local/lib" }
+ end
+
+@@ -23,10 +23,10 @@ project "mars" + defines { "_DEBUG", "DEBUG" }
+ flags { "Symbols" }
+ if os.get() == "windows" then
+- links { "sfml-graphics", "sfml-audio", "sfml-system", "sfml-window", "glu32", "opengl32", "fribidi-0", "tag" }
++ links { "sfml-graphics", "sfml-audio", "sfml-system", "sfml-window", "opengl32", "fribidi-0", "tag" }
+ elseif os.get() == "macosx" then
+ links { "sfml-graphics.framework", "sfml-audio.framework", "sfml-system.framework", "sfml-window.framework", "opengl.framework", "fribidi", "tag" }
+ else
+- links { "GLU", "sfml-graphics", "sfml-audio", "sfml-system", "sfml-window", "fribidi", "tag" }
++ links { "sfml-graphics", "sfml-audio", "sfml-system", "sfml-window", "fribidi", "tag" }
+ libdirs { "/usr/lib", "/usr/local/lib" }
+ end
+diff --git a/src/Shaders/postFX.cpp b/src/Shaders/postFX.cpp +index 987f411..f767a47 100644 +--- a/src/Shaders/postFX.cpp ++++ b/src/Shaders/postFX.cpp +@@ -78,7 +78,7 @@ namespace postFX { + postFX_.loadFromFile(settings::C_dataPath + "shaders/bump.frag", sf::Shader::Fragment); + bumpMap_.create(SPACE_X_RESOLUTION*0.5f, SPACE_Y_RESOLUTION*0.5f); + glViewport(0,0,SPACE_X_RESOLUTION*0.5f,SPACE_Y_RESOLUTION*0.5f); +- gluOrtho2D(0, SPACE_X_RESOLUTION, SPACE_Y_RESOLUTION, 0); ++ glOrtho(0, SPACE_X_RESOLUTION, SPACE_Y_RESOLUTION, 0, -1, 1); + glEnable(GL_BLEND); + glMatrixMode(GL_MODELVIEW); + postFX_.setParameter("BumpMap", bumpMap_.getTexture()); +diff --git a/src/System/window.cpp b/src/System/window.cpp +index e9a099a..8e12dcc 100644 +--- a/src/System/window.cpp ++++ b/src/System/window.cpp +@@ -222,7 +222,7 @@ namespace window { + glLoadIdentity(); + + // Setup translation (according to left-upper corner) +- gluOrtho2D(0.f, SPACE_X_RESOLUTION, SPACE_Y_RESOLUTION, 0.f); ++ glOrtho(0.f, SPACE_X_RESOLUTION, SPACE_Y_RESOLUTION, 0.f, -1, 1); + + // probably improves performance... + glDisable(GL_LIGHTING); +@@ -247,7 +247,7 @@ namespace window { + + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); +- gluOrtho2D(0.f, viewPort_.x_, viewPort_.y_, 0.f); ++ glOrtho(0.f, viewPort_.x_, viewPort_.y_, 0.f, -1, 1); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); + +@@ -255,7 +255,7 @@ namespace window { + + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); +- gluOrtho2D(0.f, SPACE_X_RESOLUTION, SPACE_Y_RESOLUTION, 0.f); ++ glOrtho(0.f, SPACE_X_RESOLUTION, SPACE_Y_RESOLUTION, 0.f, -1, 1); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); + } +@@ -270,7 +270,7 @@ namespace window { + glLoadIdentity(); + setViewPort(); + +- gluOrtho2D(0.f, viewPort_.x_, viewPort_.y_, 0.f); ++ glOrtho(0.f, viewPort_.x_, viewPort_.y_, 0.f, -1, 1); + + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); +@@ -284,7 +284,7 @@ namespace window { + glLoadIdentity(); + setViewPort(); + +- gluOrtho2D(0.f, viewPort_.x_, viewPort_.y_, 0.f); ++ glOrtho(0.f, viewPort_.x_, viewPort_.y_, 0.f, -1, 1); + + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); +@@ -294,7 +294,7 @@ namespace window { + else { + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); +- gluOrtho2D(0.f, viewPort_.x_, viewPort_.y_, 0.f); ++ glOrtho(0.f, viewPort_.x_, viewPort_.y_, 0.f, -1, 1); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); + } + +From a97d0d6a19b5b43e3c53081e36f1f1747b6674e6 Mon Sep 17 00:00:00 2001 +From: Sylvain BOILARD <boilard@crans.org> +Date: Wed, 23 Jan 2013 02:02:47 +0100 +Subject: [PATCH] Use sf::Shader::Bind() correctly after latest update of the + SFML's API. + +--- + src/System/window.cpp | 6 ++---- + 1 file changed, 2 insertions(+), 4 deletions(-) + +diff --git a/src/System/window.cpp b/src/System/window.cpp +index e9a099a..3ffcf65 100644 +--- a/src/System/window.cpp ++++ b/src/System/window.cpp +@@ -307,13 +307,11 @@ namespace window { + window_.setActive(true); + glEnable(GL_TEXTURE_2D); + +- if (shader) +- shader->bind(); ++ sf::Shader::bind(shader); + + window_.draw(toBeDrawn, states); + +- if (shader) +- shader->unbind(); ++ sf::Shader::bind(NULL); + + window_.popGLStates(); + glPopMatrix(); diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index ee9173b570..fc4fad6f98 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -32,7 +32,7 @@ #:use-module ((guix licenses) #:select (asl2.0 bsd-4 bsd-3 bsd-2 non-copyleft cc0 x11 x11-style gpl2 gpl2+ gpl3+ lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3+ agpl3+ - isc psfl public-domain x11-style)) + isc psfl public-domain x11-style zpl2.1)) #:use-module ((guix licenses) #:select (expat zlib) #:prefix license:) #:use-module (gnu packages) #:use-module (gnu packages attr) @@ -1566,6 +1566,44 @@ and many external plugins.") (define-public python2-pytest (package-with-python2 python-pytest)) +(define-public python-pytest-runner + (package + (name "python-pytest-runner") + (version "2.6.2") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/p/" + "pytest-runner/pytest-runner-" + version ".tar.gz")) + (sha256 + (base32 + "1nwcqx0l3fv52kv8526wy8ypzghbq96c96di318d98d3wh7a8xg7")))) + (build-system python-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + ;; The fancy way of setting the version with setuptools_scm does not + ;; seem to work here. + (add-after 'unpack 'set-version + (lambda _ + (substitute* "docs/conf.py" + (("version = setuptools_scm\\.get_version\\(root='\\.\\.')") + (string-append "version = \"" ,version "\""))) + #t))))) + (native-inputs + `(("python-pytest" ,python-pytest) + ("python-setuptools-scm" ,python-setuptools-scm))) + (home-page "https://bitbucket.org/pytest-dev/pytest-runner") + (synopsis "Invoke py.test as a distutils command") + (description + "This package provides a @command{pytest-runner} command that +@file{setup.py} files can use to run tests.") + (license license:expat))) + +(define-public python2-pytest-runner + (package-with-python2 python-pytest-runner)) + (define-public python-scripttest (package (name "python-scripttest") @@ -1708,7 +1746,14 @@ protocol.") (define-public python2-subunit (package-with-python2 python-subunit)) -(define-public python-fixtures +;; Recent versions of python-fixtures need a recent version of python-pbr, +;; which needs a recent version of python-fixtures. To fix this circular +;; dependency, we keep old versions of python-fixtures and python-pbr to +;; bootstrap the whole thing: +;; - python-fixtures-0.3.16 is used to build python-pbr-0.11 +;; - python-pbr-0.11 is used to build python-fixtures +;; - python-fixtures is used to build python-pbr +(define-public python-fixtures-0.3.16 (package (name "python-fixtures") (version "0.3.16") @@ -1733,6 +1778,70 @@ protocol.") Python tests.") (license (list bsd-3 asl2.0)))) ; at user's option +(define-public python2-fixtures-0.3.16 + (package-with-python2 python-fixtures-0.3.16)) + +(define-public python-pbr-0.11 + (package + (name "python-pbr") + (version "0.11.0") + (source + (origin + (method url-fetch) + (uri (string-append + "https://pypi.python.org/packages/source/p/pbr/pbr-" + version ".tar.gz")) + (sha256 + (base32 + "0v9gb7gyqf7q9s99l0nnjj9ww9b0jvyqlwm4d56pcyinxydddw6p")))) + (build-system python-build-system) + (arguments + `(#:tests? #f)) ;; Most tests seem to use the Internet. + (inputs + `(("python-fixtures-0.3.16" ,python-fixtures-0.3.16) + ("python-pip" ,python-pip) + ("python-setuptools" ,python-setuptools))) + (home-page "https://launchpad.net/pbr") + (synopsis "Change the default behavior of Python’s setuptools") + (description + "Python Build Reasonableness (PBR) is a library that injects some useful +and sensible default behaviors into your setuptools run.") + (license asl2.0))) + +(define-public python2-pbr-0.11 + (package-with-python2 python-pbr-0.11)) + +(define-public python-fixtures + (package + (name "python-fixtures") + (version "1.3.1") + (source + (origin + (method url-fetch) + (uri (string-append + "https://pypi.python.org/packages/source/f/fixtures/fixtures-" + version ".tar.gz")) + (sha256 + (base32 + "1khpywdh91ijryhxjxiyyi5rmbimhl8hwbbf8lazhgzq6yxz6g5n")))) + (build-system python-build-system) + (propagated-inputs + `(("python-six" ,python-six) + ("python-pbr-0.11" ,python-pbr-0.11))) + (inputs + `(("python-pip" ,python-pip) + ("python-setuptools" ,python-setuptools) + ;; Tests + ("python-testtools" ,python-testtools))) + (arguments + '(#:tests? #f)) ; no setup.py test command + (home-page "https://launchpad.net/python-fixtures") + (synopsis "Python test fixture library") + (description + "Fixtures provides a way to create reusable state, useful when writing +Python tests.") + (license (list bsd-3 asl2.0)))) ; at user's option + (define-public python2-fixtures (package-with-python2 python-fixtures)) @@ -1751,7 +1860,7 @@ Python tests.") "1ssqb07c277010i6gzzkbdd46gd9mrj0bi0i8vn560n2k2y4j93m")))) (build-system python-build-system) (propagated-inputs - `(("python-fixtures" ,python-fixtures) + `(("python-fixtures-0.3.16" ,python-fixtures-0.3.16) ("python-testtools" ,python-testtools))) (inputs `(("python-setuptools" ,python-setuptools) @@ -3679,6 +3788,204 @@ cluster without needing to write any wrapper code yourself.") (define-public python2-gridmap (package-with-python2 python-gridmap)) +(define-public python-pexpect + (package + (name "python-pexpect") + (version "3.3") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/p/" + "pexpect/pexpect-" version ".tar.gz")) + (sha256 + (base32 "1fp5gm976z7ghm8jw57463rj19cv06c8zw842prgyg788f6n3snz")))) + (build-system python-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (replace 'check (lambda _ (zero? (system* "nosetests"))))))) + (native-inputs + `(("python-nose" ,python-nose))) + (home-page "http://pexpect.readthedocs.org/") + (synopsis "Controlling interactive console applications") + (description + "Pexpect is a pure Python module for spawning child applications; +controlling them; and responding to expected patterns in their output. +Pexpect works like Don Libes’ Expect. Pexpect allows your script to spawn a +child application and control it as if a human were typing commands.") + (license isc))) + +(define-public python2-pexpect + (package-with-python2 python-pexpect)) + +(define-public python-setuptools-scm + (package + (name "python-setuptools-scm") + (version "1.8.0") + (source (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/s/" + "setuptools_scm/setuptools_scm-" + version ".tar.bz2")) + (sha256 + (base32 + "00p60v2yfqy1r58pjcx9wy6dvqd7wkpfs5z1dzwf7y75c1g3dgyx")))) + (build-system python-build-system) + (home-page "https://github.com/pypa/setuptools_scm/") + (synopsis "Manage Python package versions in SCM metadata") + (description + "setuptools_scm handles managing your Python package versions in +@dfn{software configuration management} (SCM) metadata instead of declaring +them as the version argument or in a SCM managed file.") + (license license:expat))) + +(define-public python2-setuptools-scm + (package-with-python2 python-setuptools-scm)) + +(define-public python-pathpy + (package + (name "python-pathpy") + (version "8.1.1") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/p/" + "path.py/path.py-" version ".tar.gz")) + (sha256 + (base32 "1p8s1l2vfkqhqxdhqlj0g1jjw4f1as2frr35sjcpjjpd5a89y41f")))) + (build-system python-build-system) + (propagated-inputs + `(("python-appdirs" ,python-appdirs))) + (native-inputs + `(("python-setuptools-scm" ,python-setuptools-scm) + ("python-pytest" ,python-pytest) + ("python-pytest-runner" ,python-pytest-runner))) + (home-page "http://github.com/jaraco/path.py") + (synopsis "Python module wrapper for built-in os.path") + (description + "@code{path.py} implements path objects as first-class entities, allowing +common operations on files to be invoked on those path objects directly.") + (license license:expat))) + +(define-public python2-pathpy + (package-with-python2 python-pathpy)) + +(define-public python-pickleshare + (package + (name "python-pickleshare") + (version "0.5") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/p/" + "pickleshare/pickleshare-" version ".tar.gz")) + (sha256 + (base32 "11ljr90j3p6qswdrbl7p4cjb2i93f6vn0vx9anzpshsx0d2mggn0")))) + (build-system python-build-system) + (propagated-inputs + `(("python-pathpy" ,python-pathpy))) + (home-page "https://github.com/vivainio/pickleshare") + (synopsis "Tiny key value database with concurrency support") + (description + "PickleShare is a small ‘shelve’-like datastore with concurrency support. +Like shelve, a PickleShareDB object acts like a normal dictionary. Unlike +shelve, many processes can access the database simultaneously. Changing a +value in database is immediately visible to other processes accessing the same +database. Concurrency is possible because the values are stored in separate +files. Hence the “database” is a directory where all files are governed by +PickleShare.") + (license license:expat))) + +(define-public python2-pickleshare + (package-with-python2 python-pickleshare)) + +(define-public python-simplegeneric + (package + (name "python-simplegeneric") + (version "0.8.1") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/s/" + "simplegeneric/simplegeneric-" version ".zip")) + (sha256 + (base32 "0wwi1c6md4vkbcsfsf8dklf3vr4mcdj4mpxkanwgb6jb1432x5yw")))) + (build-system python-build-system) + (native-inputs + `(("unzip" ,unzip))) + (home-page "http://cheeseshop.python.org/pypi/simplegeneric") + (synopsis "Python module for simple generic functions") + (description + "The simplegeneric module lets you define simple single-dispatch generic +functions, akin to Python’s built-in generic functions like @code{len()}, +@code{iter()} and so on. However, instead of using specially-named methods, +these generic functions use simple lookup tables, akin to those used by +e.g. @code{pickle.dump()} and other generic functions found in the Python +standard library.") + (license zpl2.1))) + +(define-public python2-simplegeneric + (package-with-python2 python-simplegeneric)) + +(define-public python-ipython-genutils + (package + (name "python-ipython-genutils") + (version "0.1.0") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/i/" + "ipython_genutils/ipython_genutils-" + version ".tar.gz")) + (sha256 + (base32 "19l2pp1c64ansr89l3cqh19jdi2ixhssdzx0vz4n6r52a6i281is")))) + (build-system python-build-system) + (arguments `(#:tests? #f)) ; no tests + (home-page "http://ipython.org") + (synopsis "Vestigial utilities from IPython") + (description + "This package provides retired utilities from IPython.") + (license bsd-3))) + +(define-public python2-ipython-genutils + (package-with-python2 python-ipython-genutils)) + +(define-public python-traitlets + (package + (name "python-traitlets") + (version "4.0.0") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/t/" + "traitlets/traitlets-" version ".tar.gz")) + (sha256 + (base32 + "0fr3w2xwb46c591dp7zw02bgf4d21mjy9g6rhwc9bwd4ji50n50b")))) + (build-system python-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (replace 'check (lambda _ (zero? (system* "nosetests"))))))) + (propagated-inputs + `(("python-ipython-genutils" ,python-ipython-genutils) + ("python-decorator" ,python-decorator))) + (native-inputs + `(("python-nose" ,python-nose))) + (home-page "http://ipython.org") + (synopsis "Configuration system for Python applications") + (description + "Traitlets is a framework that lets Python classes have attributes with +type checking, dynamically calculated default values, and ‘on change’ +callbacks. The package also includes a mechanism to use traitlets for +configuration, loading values from files or from command line arguments. This +is a distinct layer on top of traitlets, so you can use traitlets in your code +without using the configuration machinery.") + (license bsd-3))) + +(define-public python2-traitlets + (package-with-python2 python-traitlets)) + (define-public python-ipython (package (name "python-ipython") @@ -5268,3 +5575,35 @@ library.") `(("python2-cryptography" ,python2-cryptography) ,@(alist-delete "python-cryptography" (package-propagated-inputs pyopenssl))))))) + +(define-public python-pip + (package + (name "python-pip") + (version "7.1.2") + (source + (origin + (method url-fetch) + (uri (string-append + "https://pypi.python.org/packages/source/p/pip/pip-" + version ".tar.gz")) + (sha256 + (base32 + "0xx4aypfgchxdknxq7gyqghd8wb221zrzyqlbabzm32jy237j16a")))) + (build-system python-build-system) + (inputs + `(("python-setuptools" ,python-setuptools) + ("python-virtualenv" ,python-virtualenv) + ;; Tests + ("python-mock" ,python-mock) + ("python-pytest" ,python-pytest) + ("python-scripttest" ,python-scripttest))) + (home-page "https://pip.pypa.io/") + (synopsis + "Package manager for Python software") + (description + "Pip is a package manager for Python software, that finds packages on the +Python Package Index (PyPI).") + (license license:expat))) + +(define-public python2-pip + (package-with-python2 python-pip)) diff --git a/gnu/packages/sdl.scm b/gnu/packages/sdl.scm index 50fe01074d..1b64be024d 100644 --- a/gnu/packages/sdl.scm +++ b/gnu/packages/sdl.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013 David Thompson <dthompson2@worcester.edu> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> +;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,7 +43,8 @@ sdl-image sdl-mixer sdl-net - sdl-ttf)) + sdl-ttf + sdl-union)) (define sdl (package @@ -268,7 +270,10 @@ SDL.") (home-page "http://www.libsdl.org/projects/SDL_ttf/") (license zlib))) -(define sdl-union +(define* (sdl-union #:optional (packages (list sdl sdl-gfx sdl-net sdl-ttf + sdl-image sdl-mixer))) + "Return 'sdl-union' package which is a union of PACKAGES. +If PACKAGES are not specified, all SDL packages are used." (package (name "sdl-union") (version (package-version sdl)) @@ -283,12 +288,10 @@ SDL.") (((names . directories) ...) (union-build (assoc-ref %outputs "out") directories)))))) - (inputs `(("sdl" ,sdl) - ("sdl-gfx" ,sdl-gfx) - ("sdl-image" ,sdl-image) - ("sdl-mixer" ,sdl-mixer) - ("sdl-ttf" ,sdl-ttf))) - (synopsis "Union of all SDL libraries") + (inputs (map (lambda (package) + (list (package-name package) package)) + packages)) + (synopsis "Union of SDL libraries") (description "A union of SDL and its extension libraries. A union is required because sdl-config assumes that all of the headers and libraries are in the same @@ -316,7 +319,7 @@ directory.") ("libjpeg" ,libjpeg))) (inputs `(("guile" ,guile-2.0) - ("sdl-union" ,sdl-union))) + ("sdl-union" ,(sdl-union)))) (arguments '(#:configure-flags (list (string-append "--with-sdl-prefix=" diff --git a/gnu/packages/wicd.scm b/gnu/packages/wicd.scm index 33953eebf0..cad078e061 100644 --- a/gnu/packages/wicd.scm +++ b/gnu/packages/wicd.scm @@ -180,7 +180,8 @@ ;; allow wicd-gtk to find its icons. (let ((hicolor (assoc-ref inputs "hicolor-icon-theme")) (name "/share/icons/hicolor/index.theme")) - (install-file (string-append hicolor name) out)) + (install-file (string-append hicolor name) + (string-append out "/share/icons/hicolor"))) #t)) %standard-phases)))) (synopsis "Network connection manager") diff --git a/gnu/services.scm b/gnu/services.scm index 43e51b998c..fdfa569b23 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,49 +18,428 @@ (define-module (gnu services) #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix store) #:use-module (guix records) - #:export (service? + #:use-module (guix sets) + #:use-module (guix ui) + #:use-module (gnu packages base) + #:use-module (gnu packages bash) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:export (service-extension + service-extension? + + service-type + service-type? + service - service-documentation - service-provision - service-requirement - service-respawn? - service-start - service-stop - service-auto-start? - service-activate - service-user-accounts - service-user-groups - service-pam-services)) - -;;; Commentary: + service? + service-kind + service-parameters + + fold-services + + service-error? + missing-target-service-error? + missing-target-service-error-service + missing-target-service-error-target-type + ambiguous-target-service-error? + ambiguous-target-service-error-service + ambiguous-target-service-error-target-type + + boot-service-type + activation-service-type + activation-service->script + etc-service-type + etc-directory + setuid-program-service-type + firmware-service-type + + %boot-service + %activation-service + etc-service + + file-union)) ;XXX: for lack of a better place + +;;; Comment: +;;; +;;; This module defines a broad notion of "service types" and "services." ;;; -;;; System services as cajoled by dmd. +;;; A service type describe how its instances extend instances of other +;;; service types. For instance, some services extend the instance of +;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create; +;;; others extend DMD-ROOT-SERVICE-TYPE by passing it instances of +;;; <dmd-service>. +;;; +;;; When applicable, the service type defines how it can itself be extended, +;;; by providing one procedure to compose extensions, and one procedure to +;;; extend itself. +;;; +;;; A notable service type is BOOT-SERVICE-TYPE, which has a single instance, +;;; %BOOT-SERVICE. %BOOT-SERVICE constitutes the root of the service DAG. It +;;; produces the boot script that the initrd loads. +;;; +;;; The 'fold-services' procedure can be passed a list of procedures, which it +;;; "folds" by propagating extensions down the graph; it returns the root +;;; service after the applying all its extensions. ;;; ;;; Code: -(define-record-type* <service> - service make-service +(define-record-type <service-extension> + (service-extension target compute) + service-extension? + (target service-extension-target) ;<service-type> + (compute service-extension-compute)) ;params -> params + +(define-record-type* <service-type> service-type make-service-type + service-type? + (name service-type-name) ;symbol (for debugging) + + ;; Things extended by services of this type. + (extensions service-type-extensions) ;list of <service-extensions> + + ;; Given a list of extensions, "compose" them. + (compose service-type-compose ;list of Any -> Any + (default #f)) + + ;; Extend the services' own parameters with the extension composition. + (extend service-type-extend ;list of Any -> parameters + (default #f))) + +(define (write-service-type type port) + (format port "#<service-type ~a ~a>" + (service-type-name type) + (number->string (object-address type) 16))) + +(set-record-type-printer! <service-type> write-service-type) + +;; Services of a given type. +(define-record-type <service> + (service type parameters) service? - (documentation service-documentation ; string - (default "[No documentation.]")) - (provision service-provision) ; list of symbols - (requirement service-requirement ; list of symbols - (default '())) - (respawn? service-respawn? ; Boolean - (default #t)) - (start service-start) ; g-expression (procedure) - (stop service-stop ; g-expression (procedure) - (default #~(const #f))) - (auto-start? service-auto-start? ; Boolean - (default #t)) - (user-accounts service-user-accounts ; list of <user-account> - (default '())) - (user-groups service-user-groups ; list of <user-groups> - (default '())) - (pam-services service-pam-services ; list of <pam-service> - (default '())) - (activate service-activate ; gexp - (default #f))) + (type service-kind) + (parameters service-parameters)) + + + + +;;; +;;; Core services. +;;; + +(define (compute-boot-script mexps) + (mlet %store-monad ((gexps (sequence %store-monad mexps))) + (gexp->file "boot" + #~(begin + (use-modules (guix build utils)) + + ;; Clean out /tmp and /var/run. + ;; + ;; XXX This needs to happen before service activations, so + ;; it has to be here, but this also implicitly assumes + ;; that /tmp and /var/run are on the root partition. + (false-if-exception (delete-file-recursively "/tmp")) + (false-if-exception (delete-file-recursively "/var/run")) + (false-if-exception (mkdir "/tmp")) + (false-if-exception (chmod "/tmp" #o1777)) + (false-if-exception (mkdir "/var/run")) + (false-if-exception (chmod "/var/run" #o755)) + + ;; Activate the system and spawn dmd. + #$@gexps)))) + +(define (second-argument a b) b) + +(define boot-service-type + ;; The service of this type is extended by being passed gexps as monadic + ;; values. It aggregates them in a single script, as a monadic value, which + ;; becomes its 'parameters'. It is the only service that extends nothing. + (service-type (name 'boot) + (extensions '()) + (compose compute-boot-script) + (extend second-argument))) + +(define %boot-service + ;; This is the ultimate service, the root of the service DAG. + (service boot-service-type #t)) + +(define* (file-union name files) ;FIXME: Factorize. + "Return a <computed-file> that builds a directory containing all of FILES. +Each item in FILES must be a list where the first element is the file name to +use in the new directory, and the second element is a gexp denoting the target +file." + (computed-file name + #~(begin + (mkdir #$output) + (chdir #$output) + #$@(map (match-lambda + ((target source) + #~(symlink #$source #$target))) + files)))) + +(define (directory-union name things) + "Return a directory that is the union of THINGS." + (match things + ((one) + ;; Only one thing; return it. + one) + (_ + (computed-file name + #~(begin + (use-modules (guix build union)) + (union-build #$output '#$things)) + #:modules '((guix build union)))))) + +(define (modprobe-wrapper) + "Return a wrapper for the 'modprobe' command that knows where modules live. + +This wrapper is typically invoked by the Linux kernel ('call_modprobe', in +kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment +variable is not set---hence the need for this wrapper." + (let ((modprobe "/run/current-system/profile/bin/modprobe")) + (gexp->script "modprobe" + #~(begin + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + (apply execl #$modprobe + (cons #$modprobe (cdr (command-line)))))))) + +(define* (activation-service->script service) + "Return as a monadic value the activation script for SERVICE, a service of +ACTIVATION-SCRIPT-TYPE." + (activation-script (service-parameters service))) + +(define (activation-script gexps) + "Return the system's activation script, which evaluates GEXPS." + (define %modules + '((gnu build activation) + (gnu build linux-boot) + (gnu build linux-modules) + (gnu build file-systems) + (guix build utils) + (guix build syscalls) + (guix elf))) + + (define (service-activations) + ;; Return the activation scripts for SERVICES. + (mapm %store-monad + (cut gexp->file "activate-service" <>) + gexps)) + + (mlet* %store-monad ((actions (service-activations)) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) + (modprobe (modprobe-wrapper))) + (gexp->file "activate" + #~(begin + (eval-when (expand load eval) + ;; Make sure 'use-modules' below succeeds. + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$compiled %load-compiled-path))) + + (use-modules (gnu build activation)) + + ;; Make sure /bin/sh is valid and current. + (activate-/bin/sh + (string-append #$(canonical-package bash) "/bin/sh")) + + ;; Tell the kernel to use our 'modprobe' command. + (activate-modprobe #$modprobe) + + ;; Let users debug their own processes! + (activate-ptrace-attach) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions) + + ;; Set up /run/current-system. + (activate-current-system))))) + +(define (gexps->activation-gexp gexps) + "Return a gexp that runs the activation script containing GEXPS." + (mlet %store-monad ((script (activation-script gexps))) + (return #~(primitive-load #$script)))) + +(define activation-service-type + (service-type (name 'activate) + (extensions + (list (service-extension boot-service-type + gexps->activation-gexp))) + (compose append) + (extend second-argument))) + +(define %activation-service + ;; The activation service produces the activation script from the gexps it + ;; receives. + (service activation-service-type #t)) + +(define (etc-directory service) + "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE." + (files->etc-directory (service-parameters service))) + +(define (files->etc-directory files) + (file-union "etc" files)) + +(define etc-service-type + (service-type (name 'etc) + (extensions + (list + (service-extension activation-service-type + (lambda (files) + (let ((etc + (files->etc-directory files))) + #~(activate-etc #$etc)))))) + (compose concatenate) + (extend append))) + +(define (etc-service files) + "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES. +FILES must be a list of name/file-like object pairs." + (service etc-service-type files)) + +(define setuid-program-service-type + (service-type (name 'setuid-program) + (extensions + (list (service-extension activation-service-type + (lambda (programs) + #~(activate-setuid-programs + (list #$@programs)))))) + (compose concatenate) + (extend append))) + +(define (firmware->activation-gexp firmware) + "Return a gexp to make the packages listed in FIRMWARE loadable by the +kernel." + (let ((directory (directory-union "firmware" firmware))) + ;; Tell the kernel where firmware is. + #~(activate-firmware (string-append #$directory "/lib/firmware")))) + +(define firmware-service-type + ;; The service that collects firmware. + (service-type (name 'firmware) + (extensions + (list (service-extension activation-service-type + firmware->activation-gexp))) + (compose concatenate) + (extend append))) + + +;;; +;;; Service folding. +;;; + +(define-condition-type &service-error &error + service-error?) + +(define-condition-type &missing-target-service-error &service-error + missing-target-service-error? + (service missing-target-service-error-service) + (target-type missing-target-service-error-target-type)) + +(define-condition-type &ambiguous-target-service-error &service-error + ambiguous-target-service-error? + (service ambiguous-target-service-error-service) + (target-type ambiguous-target-service-error-target-type)) + +(define (service-back-edges services) + "Return a procedure that, when passed a <service>, returns the list of +<service> objects that depend on it." + (define (add-edges service edges) + (define (add-edge extension edges) + (let ((target-type (service-extension-target extension))) + (match (filter (lambda (service) + (eq? (service-kind service) target-type)) + services) + ((target) + (vhash-consq target service edges)) + (() + (raise + (condition (&missing-target-service-error + (service service) + (target-type target-type)) + (&message + (message + (format #f (_ "no target of type '~a' for service ~s") + (service-type-name target-type) + service)))))) + (x + (raise + (condition (&ambiguous-target-service-error + (service service) + (target-type target-type)) + (&message + (message + (format #f + (_ "more than one target service of type '~a'") + (service-type-name target-type)))))))))) + + (fold add-edge edges (service-type-extensions (service-kind service)))) + + (let ((edges (fold add-edges vlist-null services))) + (lambda (node) + (reverse (vhash-foldq* cons '() node edges))))) + +(define* (fold-services services #:key (target-type boot-service-type)) + "Fold SERVICES by propagating their extensions down to the root of type +TARGET-TYPE; return the root service adjusted accordingly." + (define dependents + (service-back-edges services)) + + (define (matching-extension target) + (let ((target (service-kind target))) + (match-lambda + (($ <service-extension> type) + (eq? type target))))) + + (define (apply-extension target) + (lambda (service) + (match (find (matching-extension target) + (service-type-extensions (service-kind service))) + (($ <service-extension> _ compute) + (compute (service-parameters service)))))) + + (match (filter (lambda (service) + (eq? (service-kind service) target-type)) + services) + ((sink) + (let loop ((sink sink)) + (let* ((dependents (map loop (dependents sink))) + (extensions (map (apply-extension sink) dependents)) + (extend (service-type-extend (service-kind sink))) + (compose (service-type-compose (service-kind sink))) + (params (service-parameters sink))) + ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a + ;; different type than the elements of EXTENSIONS. + (if extend + (service (service-kind sink) + (extend params (compose extensions))) + sink)))) + (() + (raise + (condition (&missing-target-service-error + (service #f) + (target-type target-type)) + (&message + (message (format #f (_ "service of type '~a' not found") + (service-type-name target-type))))))) + (x + (raise + (condition (&ambiguous-target-service-error + (service #f) + (target-type target-type)) + (&message + (message + (format #f + (_ "more than one target service of type '~a'") + (service-type-name target-type))))))))) ;;; services.scm ends here. diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index a3ca5ab6fb..b576c395ff 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -18,11 +18,13 @@ (define-module (gnu services avahi) #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services dmd) + #:use-module (gnu services dbus) #:use-module (gnu system shadow) #:use-module (gnu packages avahi) #:use-module (gnu packages admin) - #:use-module (guix monads) - #:use-module (guix store) + #:use-module (guix records) #:use-module (guix gexp) #:export (avahi-service)) @@ -33,27 +35,91 @@ ;;; ;;; Code: -(define* (configuration-file #:key host-name publish? - ipv4? ipv6? wide-area? domains-to-browse) - "Return an avahi-daemon configuration file." + ;; TODO: Export. +(define-record-type* <avahi-configuration> + avahi-configuration make-avahi-configuration + avahi-configuration? + (avahi avahi-configuration-avahi ;<package> + (default avahi)) + (host-name avahi-configuration-host-name) ;string + (publish? avahi-configuration-publish?) ;Boolean + (ipv4? avahi-configuration-ipv4?) ;Boolean + (ipv6? avahi-configuration-ipv6?) ;Boolean + (wide-area? avahi-configuration-wide-area?) ;Boolean + (domains-to-browse avahi-configuration-domains-to-browse)) ;list of strings + +(define* (configuration-file config) + "Return an avahi-daemon configuration file based on CONFIG, an +<avahi-configuration>." (define (bool value) (if value "yes\n" "no\n")) - (text-file "avahi-daemon.conf" - (string-append - "[server]\n" - (if host-name - (string-append "host-name=" host-name "\n") - "") - - "browse-domains=" (string-join domains-to-browse) - "\n" - "use-ipv4=" (bool ipv4?) - "use-ipv6=" (bool ipv6?) - "[wide-area]\n" - "enable-wide-area=" (bool wide-area?) - "[publish]\n" - "disable-publishing=" (bool (not publish?))))) + (define host-name (avahi-configuration-host-name config)) + + (plain-file "avahi-daemon.conf" + (string-append + "[server]\n" + (if host-name + (string-append "host-name=" host-name "\n") + "") + + "browse-domains=" (string-join + (avahi-configuration-domains-to-browse + config)) + "\n" + "use-ipv4=" (bool (avahi-configuration-ipv4? config)) + "use-ipv6=" (bool (avahi-configuration-ipv6? config)) + "[wide-area]\n" + "enable-wide-area=" (bool (avahi-configuration-wide-area? config)) + "[publish]\n" + "disable-publishing=" + (bool (not (avahi-configuration-publish? config)))))) + +(define %avahi-accounts + ;; Account and group for the Avahi daemon. + (list (user-group (name "avahi") (system? #t)) + (user-account + (name "avahi") + (group "avahi") + (system? #t) + (comment "Avahi daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define %avahi-activation + ;; Activation gexp. + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/avahi-daemon"))) + +(define (avahi-dmd-service config) + "Return a list of <dmd-service> for CONFIG." + (let ((config (configuration-file config)) + (avahi (avahi-configuration-avahi config))) + (list (dmd-service + (documentation "Run the Avahi mDNS/DNS-SD responder.") + (provision '(avahi-daemon)) + (requirement '(dbus-system networking)) + + (start #~(make-forkexec-constructor + (list (string-append #$avahi "/sbin/avahi-daemon") + "--syslog" "-f" #$config))) + (stop #~(make-kill-destructor)))))) + +(define avahi-service-type + (service-type (name 'avahi) + (extensions + (list (service-extension dmd-root-service-type + avahi-dmd-service) + (service-extension dbus-root-service-type + (compose list + avahi-configuration-avahi)) + (service-extension account-service-type + (const %avahi-accounts)) + (service-extension activation-service-type + (const %avahi-activation)) + (service-extension nscd-service-type + (const (list nss-mdns))))))) (define* (avahi-service #:key (avahi avahi) host-name @@ -76,37 +142,11 @@ When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled. Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6 sockets." - (mlet %store-monad ((config (configuration-file #:host-name host-name - #:publish? publish? - #:ipv4? ipv4? - #:ipv6? ipv6? - #:wide-area? wide-area? - #:domains-to-browse - domains-to-browse))) - (return - (service - (documentation "Run the Avahi mDNS/DNS-SD responder.") - (provision '(avahi-daemon)) - (requirement '(dbus-system networking)) - - (start #~(make-forkexec-constructor - (list (string-append #$avahi "/sbin/avahi-daemon") - "--syslog" "-f" #$config))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/avahi-daemon"))) - - (user-groups (list (user-group - (name "avahi") - (system? #t)))) - (user-accounts (list (user-account - (name "avahi") - (group "avahi") - (system? #t) - (comment "Avahi daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (service avahi-service-type + (avahi-configuration + (avahi avahi) (host-name host-name) + (publish? publish?) (ipv4? ipv4?) (ipv6? ipv6?) + (wide-area? wide-area?) + (domains-to-browse domains-to-browse)))) ;;; avahi.scm ends here diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 7f37b3da00..adafe1b55e 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -21,9 +21,11 @@ (define-module (gnu services base) #:use-module (guix store) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu services networking) #:use-module (gnu system shadow) ; 'user-account', etc. #:use-module (gnu system linux) ; 'pam-service', etc. + #:use-module (gnu system file-systems) ; 'file-system', etc. #:use-module (gnu packages admin) #:use-module ((gnu packages linux) #:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda)) @@ -35,7 +37,6 @@ #:use-module ((gnu build file-systems) #:select (mount-flags->bit-mask)) #:use-module (guix gexp) - #:use-module (guix monads) #:use-module (guix records) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -50,7 +51,11 @@ host-name-service console-keymap-service console-font-service + udev-service-type udev-service + + mingetty-configuration + mingetty-configuration? mingetty-service %nscd-default-caches @@ -62,9 +67,14 @@ nscd-cache nscd-cache? + nscd-service-type nscd-service syslog-service + + guix-configuration + guix-configuration? guix-service + %base-services)) ;;; Commentary: @@ -74,117 +84,136 @@ ;;; ;;; Code: + +;;; +;;; File systems. +;;; + +(define %root-file-system-dmd-service + (dmd-service + (documentation "Take care of the root file system.") + (provision '(root-file-system)) + (start #~(const #t)) + (stop #~(lambda _ + ;; Return #f if successfully stopped. + (sync) + + (call-with-blocked-asyncs + (lambda () + (let ((null (%make-void-port "w"))) + ;; Close 'dmd.log'. + (display "closing log\n") + ;; XXX: Ideally we'd use 'stop-logging', but that one + ;; doesn't actually close the port as of dmd 0.1. + (close-port (@@ (dmd comm) log-output-port)) + (set! (@@ (dmd comm) log-output-port) null) + + ;; Redirect the default output ports.. + (set-current-output-port null) + (set-current-error-port null) + + ;; Close /dev/console. + (for-each close-fdes '(0 1 2)) + + ;; At this point, there are no open files left, so the + ;; root file system can be re-mounted read-only. + (mount #f "/" #f + (logior MS_REMOUNT MS_RDONLY) + #:update-mtab? #f) + + #f))))) + (respawn? #f))) + +(define root-file-system-service-type + (dmd-service-type (const %root-file-system-dmd-service))) + (define (root-file-system-service) "Return a service whose sole purpose is to re-mount read-only the root file system upon shutdown (aka. cleanly \"umounting\" root.) This service must be the root of the service dependency graph so that its 'stop' action is invoked when dmd is the only process left." - (with-monad %store-monad - (return - (service - (documentation "Take care of the root file system.") - (provision '(root-file-system)) - (start #~(const #t)) - (stop #~(lambda _ - ;; Return #f if successfully stopped. - (sync) - - (call-with-blocked-asyncs - (lambda () - (let ((null (%make-void-port "w"))) - ;; Close 'dmd.log'. - (display "closing log\n") - ;; XXX: Ideally we'd use 'stop-logging', but that one - ;; doesn't actually close the port as of dmd 0.1. - (close-port (@@ (dmd comm) log-output-port)) - (set! (@@ (dmd comm) log-output-port) null) - - ;; Redirect the default output ports.. - (set-current-output-port null) - (set-current-error-port null) - - ;; Close /dev/console. - (for-each close-fdes '(0 1 2)) - - ;; At this point, there are no open files left, so the - ;; root file system can be re-mounted read-only. - (mount #f "/" #f - (logior MS_REMOUNT MS_RDONLY) - #:update-mtab? #f) - - #f))))) - (respawn? #f))))) - -(define* (file-system-service device target type - #:key (flags '()) (check? #t) - create-mount-point? options (title 'any) - (requirements '())) - "Return a service that mounts DEVICE on TARGET as a file system TYPE with -OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for -a partition label, 'device for a device file name, or 'any. When CHECK? is -true, check the file system before mounting it. When CREATE-MOUNT-POINT? is -true, create TARGET if it does not exist yet. FLAGS is a list of symbols, -such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service -names such as device-mapping services." - (with-monad %store-monad - (return - (service - (provision (list (symbol-append 'file-system- (string->symbol target)))) - (requirement `(root-file-system ,@requirements)) - (documentation "Check, mount, and unmount the given file system.") - (start #~(lambda args - ;; FIXME: Use or factorize with 'mount-file-system'. - (let ((device (canonicalize-device-spec #$device '#$title)) - (flags #$(mount-flags->bit-mask flags))) - #$(if create-mount-point? - #~(mkdir-p #$target) - #~#t) - #$(if check? - #~(begin - ;; Make sure fsck.ext2 & co. can be found. - (setenv "PATH" - (string-append - #$e2fsprogs "/sbin:" - "/run/current-system/profile/sbin:" - (getenv "PATH"))) - (check-file-system device #$type)) - #~#t) - - (mount device #$target #$type flags #$options) - - ;; For read-only bind mounts, an extra remount is needed, - ;; as per <http://lwn.net/Articles/281157/>, which still - ;; applies to Linux 4.0. - (when (and (= MS_BIND (logand flags MS_BIND)) - (= MS_RDONLY (logand flags MS_RDONLY))) - (mount device #$target #$type - (logior MS_BIND MS_REMOUNT MS_RDONLY)))) - #t)) - (stop #~(lambda args - ;; Normally there are no processes left at this point, so - ;; TARGET can be safely unmounted. - - ;; Make sure PID 1 doesn't keep TARGET busy. - (chdir "/") - - (umount #$target) - #f)))))) - -(define (user-unmount-service known-mount-points) - "Return a service whose sole purpose is to unmount file systems not listed -in KNOWN-MOUNT-POINTS when it is stopped." - (with-monad %store-monad - (return - (service + (service root-file-system-service-type #f)) + +(define (file-system->dmd-service-name file-system) + "Return the symbol that denotes the service mounting and unmounting +FILE-SYSTEM." + (symbol-append 'file-system- + (string->symbol (file-system-mount-point file-system)))) + +(define file-system-service-type + ;; TODO(?): Make this an extensible service that takes <file-system> objects + ;; and returns a list of <dmd-service>. + (dmd-service-type + (lambda (file-system) + (let ((target (file-system-mount-point file-system)) + (device (file-system-device file-system)) + (type (file-system-type file-system)) + (title (file-system-title file-system)) + (check? (file-system-check? file-system)) + (create? (file-system-create-mount-point? file-system)) + (dependencies (file-system-dependencies file-system))) + (dmd-service + (provision (list (file-system->dmd-service-name file-system))) + (requirement `(root-file-system + ,@(map file-system->dmd-service-name dependencies))) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + ;; FIXME: Use or factorize with 'mount-file-system'. + (let ((device (canonicalize-device-spec #$device '#$title)) + (flags #$(mount-flags->bit-mask + (file-system-flags file-system)))) + #$(if create? + #~(mkdir-p #$target) + #~#t) + #$(if check? + #~(begin + ;; Make sure fsck.ext2 & co. can be found. + (setenv "PATH" + (string-append + #$e2fsprogs "/sbin:" + "/run/current-system/profile/sbin:" + (getenv "PATH"))) + (check-file-system device #$type)) + #~#t) + + (mount device #$target #$type flags + #$(file-system-options file-system)) + + ;; For read-only bind mounts, an extra remount is needed, + ;; as per <http://lwn.net/Articles/281157/>, which still + ;; applies to Linux 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (mount device #$target #$type + (logior MS_BIND MS_REMOUNT MS_RDONLY)))) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + + ;; Make sure PID 1 doesn't keep TARGET busy. + (chdir "/") + + (umount #$target) + #f))))))) + +(define* (file-system-service file-system) + "Return a service that mounts @var{file-system}, a @code{<file-system>} +object." + (service file-system-service-type file-system)) + +(define user-unmount-service-type + (dmd-service-type + (lambda (known-mount-points) + (dmd-service (documentation "Unmount manually-mounted file systems.") (provision '(user-unmount)) (start #~(const #t)) (stop #~(lambda args (define (known? mount-point) (member mount-point - (cons* "/proc" "/sys" - '#$known-mount-points))) + (cons* "/proc" "/sys" '#$known-mount-points))) ;; Make sure we don't keep the user's mount points busy. (chdir "/") @@ -201,102 +230,124 @@ in KNOWN-MOUNT-POINTS when it is stopped." (filter (negate known?) (mount-points))) #f)))))) +(define (user-unmount-service known-mount-points) + "Return a service whose sole purpose is to unmount file systems not listed +in KNOWN-MOUNT-POINTS when it is stopped." + (service user-unmount-service-type known-mount-points)) + (define %do-not-kill-file ;; Name of the file listing PIDs of processes that must survive when halting ;; the system. Typical example is user-space file systems. "/etc/dmd/do-not-kill") -(define* (user-processes-service requirements #:key (grace-delay 4)) +(define user-processes-service-type + (dmd-service-type + (match-lambda + ((requirements grace-delay) + (dmd-service + (documentation "When stopped, terminate all user processes.") + (provision '(user-processes)) + (requirement (cons 'root-file-system + (map file-system->dmd-service-name + requirements))) + (start #~(const #t)) + (stop #~(lambda _ + (define (kill-except omit signal) + ;; Kill all the processes with SIGNAL except those listed + ;; in OMIT and the current process. + (let ((omit (cons (getpid) omit))) + (for-each (lambda (pid) + (unless (memv pid omit) + (false-if-exception + (kill pid signal)))) + (processes)))) + + (define omitted-pids + ;; List of PIDs that must not be killed. + (if (file-exists? #$%do-not-kill-file) + (map string->number + (call-with-input-file #$%do-not-kill-file + (compose string-tokenize + (@ (ice-9 rdelim) read-string)))) + '())) + + (define (now) + (car (gettimeofday))) + + (define (sleep* n) + ;; Really sleep N seconds. + ;; Work around <http://bugs.gnu.org/19581>. + (define start (now)) + (let loop ((elapsed 0)) + (when (> n elapsed) + (sleep (- n elapsed)) + (loop (- (now) start))))) + + (define lset= (@ (srfi srfi-1) lset=)) + + (display "sending all processes the TERM signal\n") + + (if (null? omitted-pids) + (begin + ;; Easy: terminate all of them. + (kill -1 SIGTERM) + (sleep* #$grace-delay) + (kill -1 SIGKILL)) + (begin + ;; Kill them all except OMITTED-PIDS. XXX: We would + ;; like to (kill -1 SIGSTOP) to get a fixed list of + ;; processes, like 'killall5' does, but that seems + ;; unreliable. + (kill-except omitted-pids SIGTERM) + (sleep* #$grace-delay) + (kill-except omitted-pids SIGKILL) + (delete-file #$%do-not-kill-file))) + + (let wait () + (let ((pids (processes))) + (unless (lset= = pids (cons 1 omitted-pids)) + (format #t "waiting for process termination\ + (processes left: ~s)~%" + pids) + (sleep* 2) + (wait)))) + + (display "all processes have been terminated\n") + #f)) + (respawn? #f)))))) + +(define* (user-processes-service file-systems #:key (grace-delay 4)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM has been sent are terminated with SIGKILL. -The returned service will depend on 'root-file-system' and on all the services -listed in REQUIREMENTS. +The returned service will depend on 'root-file-system' and on all the dmd +services corresponding to FILE-SYSTEMS. All the services that spawn processes must depend on this one so that they are stopped before 'kill' is called." - (with-monad %store-monad - (return (service - (documentation "When stopped, terminate all user processes.") - (provision '(user-processes)) - (requirement (cons 'root-file-system requirements)) - (start #~(const #t)) - (stop #~(lambda _ - (define (kill-except omit signal) - ;; Kill all the processes with SIGNAL except those - ;; listed in OMIT and the current process. - (let ((omit (cons (getpid) omit))) - (for-each (lambda (pid) - (unless (memv pid omit) - (false-if-exception - (kill pid signal)))) - (processes)))) - - (define omitted-pids - ;; List of PIDs that must not be killed. - (if (file-exists? #$%do-not-kill-file) - (map string->number - (call-with-input-file #$%do-not-kill-file - (compose string-tokenize - (@ (ice-9 rdelim) read-string)))) - '())) - - (define (now) - (car (gettimeofday))) - - (define (sleep* n) - ;; Really sleep N seconds. - ;; Work around <http://bugs.gnu.org/19581>. - (define start (now)) - (let loop ((elapsed 0)) - (when (> n elapsed) - (sleep (- n elapsed)) - (loop (- (now) start))))) - - (define lset= (@ (srfi srfi-1) lset=)) - - (display "sending all processes the TERM signal\n") - - (if (null? omitted-pids) - (begin - ;; Easy: terminate all of them. - (kill -1 SIGTERM) - (sleep* #$grace-delay) - (kill -1 SIGKILL)) - (begin - ;; Kill them all except OMITTED-PIDS. XXX: We - ;; would like to (kill -1 SIGSTOP) to get a fixed - ;; list of processes, like 'killall5' does, but - ;; that seems unreliable. - (kill-except omitted-pids SIGTERM) - (sleep* #$grace-delay) - (kill-except omitted-pids SIGKILL) - (delete-file #$%do-not-kill-file))) - - (let wait () - (let ((pids (processes))) - (unless (lset= = pids (cons 1 omitted-pids)) - (format #t "waiting for process termination\ - (processes left: ~s)~%" - pids) - (sleep* 2) - (wait)))) + (service user-processes-service-type + (list file-systems grace-delay))) + + +;;; +;;; Console & co. +;;; - (display "all processes have been terminated\n") - #f)) - (respawn? #f))))) +(define host-name-service-type + (dmd-service-type + (lambda (name) + (dmd-service + (documentation "Initialize the machine's host name.") + (provision '(host-name)) + (start #~(lambda _ + (sethostname #$name))) + (respawn? #f))))) (define (host-name-service name) "Return a service that sets the host name to @var{name}." - (with-monad %store-monad - (return (service - (documentation "Initialize the machine's host name.") - (provision '(host-name)) - (start #~(lambda _ - (sethostname #$name))) - (respawn? #f))))) + (service host-name-service-type name)) (define (unicode-start tty) "Return a gexp to start Unicode support on @var{tty}." @@ -316,108 +367,122 @@ stopped before 'kill' is called." (else (zero? (cdr (waitpid pid)))))))) -(define (console-keymap-service file) - "Return a service to load console keymap from @var{file}." - (with-monad %store-monad - (return - (service - (documentation - (string-append "Load console keymap (loadkeys).")) +(define console-keymap-service-type + (dmd-service-type + (lambda (file) + (dmd-service + (documentation (string-append "Load console keymap (loadkeys).")) (provision '(console-keymap)) (start #~(lambda _ (zero? (system* (string-append #$kbd "/bin/loadkeys") #$file)))) (respawn? #f))))) +(define (console-keymap-service file) + "Return a service to load console keymap from @var{file}." + (service console-keymap-service-type file)) + +(define console-font-service-type + (dmd-service-type + (match-lambda + ((tty font) + (let ((device (string-append "/dev/" tty))) + (dmd-service + (documentation "Load a Unicode console font.") + (provision (list (symbol-append 'console-font- + (string->symbol tty)))) + + ;; Start after mingetty has been started on TTY, otherwise the settings + ;; are ignored. + (requirement (list (symbol-append 'term- + (string->symbol tty)))) + + (start #~(lambda _ + (and #$(unicode-start device) + (zero? + (system* (string-append #$kbd "/bin/setfont") + "-C" #$device #$font))))) + (stop #~(const #t)) + (respawn? #f))))))) + (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16")) "Return a service that sets up Unicode support in @var{tty} and loads @var{font} for that tty (fonts are per virtual console in Linux.)" ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode ;; codepoints notably found in the UTF-8 manual. - (let ((device (string-append "/dev/" tty))) - (with-monad %store-monad - (return (service - (documentation "Load a Unicode console font.") - (provision (list (symbol-append 'console-font- - (string->symbol tty)))) - - ;; Start after mingetty has been started on TTY, otherwise the - ;; settings are ignored. - (requirement (list (symbol-append 'term- - (string->symbol tty)))) - - (start #~(lambda _ - (and #$(unicode-start device) - (zero? - (system* (string-append #$kbd "/bin/setfont") - "-C" #$device #$font))))) - (stop #~(const #t)) - (respawn? #f)))))) - -(define* (mingetty-service tty - #:key - (motd (text-file "motd" "Welcome.\n")) - auto-login - login-program - login-pause? - - ;; Allow empty passwords by default so that - ;; first-time users can log in when the 'root' - ;; account has just been created. - (allow-empty-passwords? #t)) - "Return a service to run mingetty on @var{tty}. - -When @var{allow-empty-passwords?} is true, allow empty log-in password. When -@var{auto-login} is true, it must be a user name under which to log-in -automatically. @var{login-pause?} can be set to @code{#t} in conjunction with -@var{auto-login}, in which case the user will have to press a key before the -login shell is launched. - -When true, @var{login-program} is a gexp or a monadic gexp denoting the name -of the log-in program (the default is the @code{login} program from the Shadow -tool suite.) - -@var{motd} is a monadic value containing a text file to use as -the ``message of the day''." - (mlet %store-monad ((motd motd) - (login-program (cond ((gexp? login-program) - (return login-program)) - ((not login-program) - (return #f)) - (else - login-program)))) - (return - (service - (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' - ;; service to be done. Also wait for udev essentially so that the tty - ;; text is not lost in the middle of kernel messages (XXX). - (requirement '(user-processes host-name udev)) - - (start #~(make-forkexec-constructor - (list (string-append #$mingetty "/sbin/mingetty") - "--noclear" #$tty - #$@(if auto-login - #~("--autologin" #$auto-login) - #~()) - #$@(if login-program - #~("--loginprog" #$login-program) - #~()) - #$@(if login-pause? - #~("--loginpause") - #~())))) - (stop #~(make-kill-destructor)) - - (pam-services - ;; Let 'login' be known to PAM. All the mingetty services will have - ;; that PAM service, but that's fine because they're all identical and - ;; duplicates are removed. - (list (unix-pam-service "login" - #:allow-empty-passwords? allow-empty-passwords? - #:motd motd))))))) + (service console-font-service-type (list tty font))) + +(define-record-type* <mingetty-configuration> + mingetty-configuration make-mingetty-configuration + mingetty-configuration? + (mingetty mingetty-configuration-mingetty ;<package> + (default mingetty)) + (tty mingetty-configuration-tty) ;string + (motd mingetty-configuration-motd ;file-like + (default (plain-file "motd" "Welcome.\n"))) + (auto-login mingetty-auto-login ;string | #f + (default #f)) + (login-program mingetty-login-program ;gexp + (default #f)) + (login-pause? mingetty-login-pause? ;Boolean + (default #f)) + + ;; Allow empty passwords by default so that first-time users can log in when + ;; the 'root' account has just been created. + (allow-empty-passwords? mingetty-configuration-allow-empty-passwords? + (default #t))) ;Boolean + +(define (mingetty-pam-service conf) + "Return the list of PAM service needed for CONF." + ;; Let 'login' be known to PAM. All the mingetty services will have that + ;; PAM service, but that's fine because they're all identical and duplicates + ;; are removed. + (list (unix-pam-service "login" + #:allow-empty-passwords? + (mingetty-configuration-allow-empty-passwords? conf) + #:motd + (mingetty-configuration-motd conf)))) + +(define mingetty-dmd-service + (match-lambda + (($ <mingetty-configuration> mingetty tty motd auto-login login-program + login-pause? allow-empty-passwords?) + (list + (dmd-service + (documentation "Run mingetty on an tty.") + (provision (list (symbol-append 'term- (string->symbol tty)))) + + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. Also wait for udev essentially so that the tty + ;; text is not lost in the middle of kernel messages (XXX). + (requirement '(user-processes host-name udev)) + + (start #~(make-forkexec-constructor + (list (string-append #$mingetty "/sbin/mingetty") + "--noclear" #$tty + #$@(if auto-login + #~("--autologin" #$auto-login) + #~()) + #$@(if login-program + #~("--loginprog" #$login-program) + #~()) + #$@(if login-pause? + #~("--loginpause") + #~())))) + (stop #~(make-kill-destructor))))))) + +(define mingetty-service-type + (service-type (name 'mingetty) + (extensions (list (service-extension dmd-root-service-type + mingetty-dmd-service) + (service-extension pam-root-service-type + mingetty-pam-service))))) + +(define* (mingetty-service config) + "Return a service to run mingetty according to @var{config}, which specifies +the tty to run, among other things." + (service mingetty-service-type config)) (define-record-type* <nscd-configuration> nscd-configuration make-nscd-configuration @@ -428,7 +493,11 @@ the ``message of the day''." (default 0)) ;; TODO: See nscd.conf in glibc for other options to add. (caches nscd-configuration-caches ;list of <nscd-cache> - (default %nscd-default-caches))) + (default %nscd-default-caches)) + (name-services nscd-configuration-name-services ;list of <packages> + (default '())) + (glibc nscd-configuration-glibc ;<package> + (default (canonical-package glibc)))) (define-record-type* <nscd-cache> nscd-cache make-nscd-cache nscd-cache? @@ -479,85 +548,115 @@ the ``message of the day''." @code{<nscd-configuration>} object." (define cache->config (match-lambda - (($ <nscd-cache> (= symbol->string database) - positive-ttl negative-ttl size check-files? - persistent? shared? max-size propagate?) - (string-append "\nenable-cache\t" database "\tyes\n" - - "positive-time-to-live\t" database "\t" - (number->string positive-ttl) "\n" - "negative-time-to-live\t" database "\t" - (number->string negative-ttl) "\n" - "suggested-size\t" database "\t" - (number->string size) "\n" - "check-files\t" database "\t" - (if check-files? "yes\n" "no\n") - "persistent\t" database "\t" - (if persistent? "yes\n" "no\n") - "shared\t" database "\t" - (if shared? "yes\n" "no\n") - "max-db-size\t" database "\t" - (number->string max-size) "\n" - "auto-propagate\t" database "\t" - (if propagate? "yes\n" "no\n"))))) + (($ <nscd-cache> (= symbol->string database) + positive-ttl negative-ttl size check-files? + persistent? shared? max-size propagate?) + (string-append "\nenable-cache\t" database "\tyes\n" + + "positive-time-to-live\t" database "\t" + (number->string positive-ttl) "\n" + "negative-time-to-live\t" database "\t" + (number->string negative-ttl) "\n" + "suggested-size\t" database "\t" + (number->string size) "\n" + "check-files\t" database "\t" + (if check-files? "yes\n" "no\n") + "persistent\t" database "\t" + (if persistent? "yes\n" "no\n") + "shared\t" database "\t" + (if shared? "yes\n" "no\n") + "max-db-size\t" database "\t" + (number->string max-size) "\n" + "auto-propagate\t" database "\t" + (if propagate? "yes\n" "no\n"))))) (match config (($ <nscd-configuration> log-file debug-level caches) - (text-file "nscd.conf" - (string-append "\ + (plain-file "nscd.conf" + (string-append "\ # Configuration of libc's name service cache daemon (nscd).\n\n" - (if log-file - (string-append "logfile\t" log-file) - "") - "\n" - (if debug-level - (string-append "debug-level\t" - (number->string debug-level)) - "") - "\n" - (string-concatenate - (map cache->config caches))))))) - -(define* (nscd-service #:optional (config %nscd-default-configuration) - #:key (glibc (canonical-package glibc)) - (name-services '())) + (if log-file + (string-append "logfile\t" log-file) + "") + "\n" + (if debug-level + (string-append "debug-level\t" + (number->string debug-level)) + "") + "\n" + (string-concatenate + (map cache->config caches))))))) + +(define (nscd-dmd-service config) + "Return a dmd service for CONFIG, an <nscd-configuration> object." + (let ((nscd.conf (nscd.conf-file config)) + (name-services (nscd-configuration-name-services config))) + (list (dmd-service + (documentation "Run libc's name service cache daemon (nscd).") + (provision '(nscd)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$(nscd-configuration-glibc config) + "/sbin/nscd") + "-f" #$nscd.conf "--foreground") + + #:environment-variables + (list (string-append "LD_LIBRARY_PATH=" + (string-join + (map (lambda (dir) + (string-append dir "/lib")) + (list #$@name-services)) + ":"))))) + (stop #~(make-kill-destructor)) + + (respawn? #f))))) + +(define nscd-activation + ;; Actions to take before starting nscd. + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd") + (mkdir-p "/var/db/nscd"))) ;for the persistent cache + +(define nscd-service-type + (service-type (name 'nscd) + (extensions + (list (service-extension activation-service-type + (const nscd-activation)) + (service-extension dmd-root-service-type + nscd-dmd-service))) + + ;; This can be extended by providing additional name services + ;; such as nss-mdns. + (compose concatenate) + (extend (lambda (config name-services) + (nscd-configuration + (inherit config) + (name-services (append + (nscd-configuration-name-services config) + name-services))))))) + +(define* (nscd-service #:optional (config %nscd-default-configuration)) "Return a service that runs libc's name service cache daemon (nscd) with the -given @var{config}---an @code{<nscd-configuration>} object. Optionally, -@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." - (mlet %store-monad ((nscd.conf (nscd.conf-file config))) - (return (service - (documentation "Run libc's name service cache daemon (nscd).") - (provision '(nscd)) - (requirement '(user-processes)) - - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/nscd") - (mkdir-p "/var/db/nscd"))) ;for the persistent cache - - (start #~(make-forkexec-constructor - (list (string-append #$glibc "/sbin/nscd") - "-f" #$nscd.conf "--foreground") - - #:environment-variables - (list (string-append "LD_LIBRARY_PATH=" - (string-join - (map (lambda (dir) - (string-append dir "/lib")) - (list #$@name-services)) - ":"))))) - (stop #~(make-kill-destructor)) - - (respawn? #f))))) - -(define* (syslog-service #:key config-file) - "Return a service that runs @code{syslogd}. -If configuration file name @var{config-file} is not specified, use some -reasonable default settings." +given @var{config}---an @code{<nscd-configuration>} object. @xref{Name +Service Switch}, for an example." + (service nscd-service-type config)) + +(define syslog-service-type + (dmd-service-type + (lambda (config-file) + (dmd-service + (documentation "Run the syslog daemon (syslogd).") + (provision '(syslogd)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$inetutils "/libexec/syslogd") + "--no-detach" "--rcfile" #$config-file))) + (stop #~(make-kill-destructor)))))) - ;; Snippet adapted from the GNU inetutils manual. - (define contents " +;; Snippet adapted from the GNU inetutils manual. +(define %default-syslog.conf + (plain-file "syslog.conf" " # Log all error messages, authentication messages of # level notice or higher and anything of level err or # higher to the console. @@ -576,20 +675,13 @@ reasonable default settings." # Log all the mail messages in one place. mail.* /var/log/maillog -") +")) - (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents))) - (return - (service - (documentation "Run the syslog daemon (syslogd).") - (provision '(syslogd)) - (requirement '(user-processes)) - (start - #~(make-forkexec-constructor - (list (string-append #$inetutils "/libexec/syslogd") - "--no-detach" "--rcfile" #$(or config-file syslog.conf)))) - (stop #~(make-kill-destructor)))))) +(define* (syslog-service #:key (config-file %default-syslog.conf)) + "Return a service that runs @code{syslogd}. +If configuration file name @var{config-file} is not specified, use some +reasonable default settings." + (service syslog-service-type config-file)) (define* (guix-build-accounts count #:key (group "guixbuild") @@ -638,63 +730,104 @@ GUIX." (format (current-error-port) "warning: \ failed to register hydra.gnu.org public key: ~a~%" status)))))))) -(define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-accounts 10) (authorize-hydra-key? #t) - (use-substitutes? #t) - (extra-options '()) - (lsof lsof) (lsh lsh)) - "Return a service that runs the build daemon from @var{guix}, and has -@var{build-accounts} user accounts available under @var{builder-group}. - -When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key -provided by @var{guix} is authorized upon activation, meaning that substitutes -from @code{hydra.gnu.org} are used by default. - -If @var{use-substitutes?} is false, the daemon is run with -@option{--no-substitutes} (@pxref{Invoking guix-daemon, -@option{--no-substitutes}}). - -Finally, @var{extra-options} is a list of additional command-line options -passed to @command{guix-daemon}." - (define activate - ;; Assume that the store has BUILDER-GROUP as its group. We could - ;; otherwise call 'chown' here, but the problem is that on a COW unionfs, - ;; chown leads to an entire copy of the tree, which is a bad idea. - - ;; Optionally authorize hydra.gnu.org's key. - (and authorize-hydra-key? - (hydra-key-authorization guix))) - - (with-monad %store-monad - (return (service - (documentation "Run the Guix daemon.") - (provision '(guix-daemon)) - (requirement '(user-processes)) - (start - #~(make-forkexec-constructor - (list (string-append #$guix "/bin/guix-daemon") - "--build-users-group" #$builder-group - #$@(if use-substitutes? - '() - '("--no-substitutes")) - #$@extra-options) - - ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the - ;; daemon's $PATH. - #:environment-variables - (list (string-append "PATH=" #$lsof "/bin:" - #$lsh "/bin")))) - (stop #~(make-kill-destructor)) - (user-accounts (guix-build-accounts build-accounts - #:group builder-group)) - (user-groups (list (user-group - (name builder-group) - (system? #t) - - ;; Use a fixed GID so that we can create the - ;; store with the right owner. - (id 30000)))) - (activate activate))))) +(define-record-type* <guix-configuration> + guix-configuration make-guix-configuration + guix-configuration? + (guix guix-configuration-guix ;<package> + (default guix)) + (build-group guix-configuration-build-group ;string + (default "guixbuild")) + (build-accounts guix-configuration-build-accounts ;integer + (default 10)) + (authorize-key? guix-configuration-authorize-key? ;Boolean + (default #t)) + (use-substitutes? guix-configuration-use-substitutes? ;Boolean + (default #t)) + (extra-options guix-configuration-extra-options ;list of strings + (default '())) + (lsof guix-configuration-lsof ;<package> + (default lsof)) + (lsh guix-configuration-lsh ;<package> + (default lsh))) + +(define %default-guix-configuration + (guix-configuration)) + +(define (guix-dmd-service config) + "Return a <dmd-service> for the Guix daemon service with CONFIG." + (match config + (($ <guix-configuration> guix build-group build-accounts authorize-key? + use-substitutes? extra-options lsof lsh) + (list (dmd-service + (documentation "Run the Guix daemon.") + (provision '(guix-daemon)) + (requirement '(user-processes)) + (start + #~(make-forkexec-constructor + (list (string-append #$guix "/bin/guix-daemon") + "--build-users-group" #$build-group + #$@(if use-substitutes? + '() + '("--no-substitutes")) + #$@extra-options) + + ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the + ;; daemon's $PATH. + #:environment-variables + (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin")))) + (stop #~(make-kill-destructor))))))) + +(define (guix-accounts config) + "Return the user accounts and user groups for CONFIG." + (match config + (($ <guix-configuration> _ build-group build-accounts) + (cons (user-group + (name build-group) + (system? #t) + + ;; Use a fixed GID so that we can create the store with the right + ;; owner. + (id 30000)) + (guix-build-accounts build-accounts + #:group build-group))))) + +(define (guix-activation config) + "Return the activation gexp for CONFIG." + (match config + (($ <guix-configuration> guix build-group build-accounts authorize-key?) + ;; Assume that the store has BUILD-GROUP as its group. We could + ;; otherwise call 'chown' here, but the problem is that on a COW unionfs, + ;; chown leads to an entire copy of the tree, which is a bad idea. + + ;; Optionally authorize hydra.gnu.org's key. + (and authorize-key? + (hydra-key-authorization guix))))) + +(define guix-service-type + (service-type + (name 'guix) + (extensions + (list (service-extension dmd-root-service-type guix-dmd-service) + (service-extension account-service-type guix-accounts) + (service-extension activation-service-type guix-activation))))) + +(define* (guix-service #:optional (config %default-guix-configuration)) + "Return a service that runs the Guix build daemon according to +@var{config}." + (service guix-service-type config)) + + +;;; +;;; Udev. +;;; + +(define-record-type* <udev-configuration> + udev-configuration make-udev-configuration + udev-configuration? + (udev udev-configuration-udev ;<package> + (default udev)) + (rules udev-configuration-rules ;list of <package> + (default '()))) (define (udev-rules-union packages) "Return the union of the @code{lib/udev/rules.d} directories found in each @@ -719,149 +852,181 @@ item of @var{packages}." (union-build (string-append #$output "/lib/udev/rules.d") (filter-map rules-sub-directory '#$packages)))) - (gexp->derivation "udev-rules" build - #:modules '((guix build union) - (guix build utils)) - #:local-build? #t)) + (computed-file "udev-rules" build + #:modules '((guix build union) + (guix build utils)))) (define* (kvm-udev-rule) "Return a directory with a udev rule that changes the group of @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 ;; ourselves. - (gexp->derivation "kvm-udev-rules" - #~(begin - (use-modules (guix build utils)) - - (define rules.d - (string-append #$output "/lib/udev/rules.d")) - - (mkdir-p rules.d) - (call-with-output-file - (string-append rules.d "/90-kvm.rules") - (lambda (port) - ;; Build users are part of the "kvm" group, so we - ;; can fearlessly make /dev/kvm 660 (see - ;; <http://bugs.gnu.org/18994>, for background.) - (display "\ + (computed-file "kvm-udev-rules" + #~(begin + (use-modules (guix build utils)) + + (define rules.d + (string-append #$output "/lib/udev/rules.d")) + + (mkdir-p rules.d) + (call-with-output-file + (string-append rules.d "/90-kvm.rules") + (lambda (port) + ;; Build users are part of the "kvm" group, so we + ;; can fearlessly make /dev/kvm 660 (see + ;; <http://bugs.gnu.org/18994>, for background.) + (display "\ KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port)))) - #:modules '((guix build utils)))) + #:modules '((guix build utils)))) + +(define udev-dmd-service + ;; Return a <dmd-service> for UDEV with RULES. + (match-lambda + (($ <udev-configuration> udev rules) + (let* ((rules (udev-rules-union (cons* udev (kvm-udev-rule) rules))) + (udev.conf (computed-file "udev.conf" + #~(call-with-output-file #$output + (lambda (port) + (format port + "udev_rules=\"~a/lib/udev/rules.d\"\n" + #$rules)))))) + (list + (dmd-service + (provision '(udev)) + + ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can + ;; be added: see + ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>. + (requirement '(root-file-system)) + + (documentation "Populate the /dev directory, dynamically.") + (start #~(lambda () + (define find + (@ (srfi srfi-1) find)) + + (define udevd + ;; Choose the right 'udevd'. + (find file-exists? + (map (lambda (suffix) + (string-append #$udev suffix)) + '("/libexec/udev/udevd" ;udev + "/sbin/udevd")))) ;eudev + + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) + + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + + ;; The first one is for udev, the second one for eudev. + (setenv "UDEV_CONFIG_FILE" #$udev.conf) + (setenv "EUDEV_RULES_DIRECTORY" + (string-append #$rules "/lib/udev/rules.d")) + + (let ((pid (primitive-fork))) + (case pid + ((0) + (exec-command (list udevd))) + (else + ;; Wait until udevd is up and running. This + ;; appears to be needed so that the events + ;; triggered below are actually handled. + (wait-for-udevd) + + ;; Trigger device node creation. + (system* (string-append #$udev "/bin/udevadm") + "trigger" "--action=add") + + ;; Wait for things to settle down. + (system* (string-append #$udev "/bin/udevadm") + "settle") + pid))))) + (stop #~(make-kill-destructor)) + + ;; When halting the system, 'udev' is actually killed by + ;; 'user-processes', i.e., before its own 'stop' method was called. + ;; Thus, make sure it is not respawned. + (respawn? #f))))))) + +(define udev-service-type + (service-type (name 'udev) + (extensions + (list (service-extension dmd-root-service-type + udev-dmd-service))) + + (compose concatenate) ;concatenate the list of rules + (extend (lambda (config rules) + (match config + (($ <udev-configuration> udev initial-rules) + (udev-configuration + (udev udev) + (rules (append initial-rules rules))))))))) (define* (udev-service #:key (udev eudev) (rules '())) "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get extra rules from the packages listed in @var{rules}." - (mlet* %store-monad ((kvm (kvm-udev-rule)) - (rules (udev-rules-union (cons* udev kvm rules))) - (udev.conf (text-file* "udev.conf" - "udev_rules=\"" rules - "/lib/udev/rules.d\"\n"))) - (return (service - (provision '(udev)) - - ;; Udev needs /dev to be a 'devtmpfs' mount so that new device - ;; nodes can be added: see - ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>. - (requirement '(root-file-system)) - - (documentation "Populate the /dev directory, dynamically.") - (start #~(lambda () - (define find - (@ (srfi srfi-1) find)) - - (define udevd - ;; Choose the right 'udevd'. - (find file-exists? - (map (lambda (suffix) - (string-append #$udev suffix)) - '("/libexec/udev/udevd" ;udev - "/sbin/udevd")))) ;eudev - - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) - - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - - ;; The first one is for udev, the second one for eudev. - (setenv "UDEV_CONFIG_FILE" #$udev.conf) - (setenv "EUDEV_RULES_DIRECTORY" - (string-append #$rules "/lib/udev/rules.d")) - - (let ((pid (primitive-fork))) - (case pid - ((0) - (exec-command (list udevd))) - (else - ;; Wait until udevd is up and running. This - ;; appears to be needed so that the events - ;; triggered below are actually handled. - (wait-for-udevd) - - ;; Trigger device node creation. - (system* (string-append #$udev "/bin/udevadm") - "trigger" "--action=add") - - ;; Wait for things to settle down. - (system* (string-append #$udev "/bin/udevadm") - "settle") - pid))))) - (stop #~(make-kill-destructor)) - - ;; When halting the system, 'udev' is actually killed by - ;; 'user-processes', i.e., before its own 'stop' method was - ;; called. Thus, make sure it is not respawned. - (respawn? #f))))) + (service udev-service-type + (udev-configuration (udev udev) (rules rules)))) + +(define device-mapping-service-type + (dmd-service-type + (match-lambda + ((target open close) + (dmd-service + (provision (list (symbol-append 'device-mapping- (string->symbol target)))) + (requirement '(udev)) + (documentation "Map a device node using Linux's device mapper.") + (start #~(lambda () #$open)) + (stop #~(lambda _ (not #$close))) + (respawn? #f)))))) (define (device-mapping-service target open close) "Return a service that maps device @var{target}, a string such as @code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a gexp, to open it, and evaluate @var{close} to close it." - (with-monad %store-monad - (return (service - (provision (list (symbol-append 'device-mapping- - (string->symbol target)))) - (requirement '(udev)) - (documentation "Map a device node using Linux's device mapper.") - (start #~(lambda () #$open)) - (stop #~(lambda _ (not #$close))) - (respawn? #f))))) + (service device-mapping-service-type + (list target open close))) + +(define swap-service-type + (dmd-service-type + (lambda (device) + (define requirement + (if (string-prefix? "/dev/mapper/" device) + (list (symbol-append 'device-mapping- + (string->symbol (basename device)))) + '())) + + (dmd-service + (provision (list (symbol-append 'swap- (string->symbol device)))) + (requirement `(udev ,@requirement)) + (documentation "Enable the given swap device.") + (start #~(lambda () + (restart-on-EINTR (swapon #$device)) + #t)) + (stop #~(lambda _ + (restart-on-EINTR (swapoff #$device)) + #f)) + (respawn? #f))))) (define (swap-service device) "Return a service that uses @var{device} as a swap device." - (define requirement - (if (string-prefix? "/dev/mapper/" device) - (list (symbol-append 'device-mapping- - (string->symbol (basename device)))) - '())) - - (with-monad %store-monad - (return (service - (provision (list (symbol-append 'swap- (string->symbol device)))) - (requirement `(udev ,@requirement)) - (documentation "Enable the given swap device.") - (start #~(lambda () - (restart-on-EINTR (swapon #$device)) - #t)) - (stop #~(lambda _ - (restart-on-EINTR (swapoff #$device)) - #f)) - (respawn? #f))))) + (service swap-service-type device)) (define %base-services ;; Convenience variable holding the basic services. - (let ((motd (text-file "motd" " + (let ((motd (plain-file "motd" " This is the GNU operating system, welcome!\n\n"))) (list (console-font-service "tty1") (console-font-service "tty2") @@ -870,12 +1035,19 @@ This is the GNU operating system, welcome!\n\n"))) (console-font-service "tty5") (console-font-service "tty6") - (mingetty-service "tty1" #:motd motd) - (mingetty-service "tty2" #:motd motd) - (mingetty-service "tty3" #:motd motd) - (mingetty-service "tty4" #:motd motd) - (mingetty-service "tty5" #:motd motd) - (mingetty-service "tty6" #:motd motd) + (mingetty-service (mingetty-configuration + (tty "tty1") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty2") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty3") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty4") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty5") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty6") (motd motd))) + (static-networking-service "lo" "127.0.0.1" #:provision '(loopback)) (syslog-service) @@ -885,9 +1057,6 @@ This is the GNU operating system, welcome!\n\n"))) ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is ;; used, so enable them by default. The FUSE and ALSA rules are ;; less critical, but handy. - ;; - ;; XXX Keep this in sync with the 'udev-service' call in - ;; %desktop-services. (udev-service #:rules (list lvm2 fuse alsa-utils crda))))) ;;; base.scm ends here diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index 18f41e74da..8fdd222a3b 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,13 +19,13 @@ (define-module (gnu services databases) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu system shadow) #:use-module (gnu packages admin) #:use-module (gnu packages databases) #:use-module (guix records) - #:use-module (guix monads) - #:use-module (guix store) #:use-module (guix gexp) + #:use-module (ice-9 match) #:export (postgresql-service)) ;;; Commentary: @@ -33,24 +34,100 @@ ;;; ;;; Code: +(define-record-type* <postgresql-configuration> + postgresql-configuration make-postgresql-configuration + postgresql-configuration? + (postgresql postgresql-configuration-postgresql ;<package> + (default postgresql)) + (config-file postgresql-configuration-file) + (data-directory postgresql-configuration-data-directory)) + (define %default-postgres-hba - (text-file "pg_hba.conf" - " + (plain-file "pg_hba.conf" + " local all all trust host all all 127.0.0.1/32 trust host all all ::1/128 trust")) (define %default-postgres-ident - (text-file "pg_ident.conf" + (plain-file "pg_ident.conf" "# MAPNAME SYSTEM-USERNAME PG-USERNAME")) (define %default-postgres-config - (mlet %store-monad ((hba %default-postgres-hba) - (ident %default-postgres-ident)) - (text-file* "postgresql.conf" - ;; The daemon will not start without these. - "hba_file = '" hba "'\n" - "ident_file = '" ident "'\n"))) + (mixed-text-file "postgresql.conf" + "hba_file = '" %default-postgres-hba "'\n" + "ident_file = '" %default-postgres-ident "\n")) + +(define %postgresql-accounts + (list (user-group (name "postgres") (system? #t)) + (user-account + (name "postgres") + (group "postgres") + (system? #t) + (comment "PostgreSQL server user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define postgresql-activation + (match-lambda + (($ <postgresql-configuration> postgresql config-file data-directory) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (let ((user (getpwnam "postgres")) + (initdb (string-append #$postgresql "/bin/initdb"))) + ;; Create db state directory. + (mkdir-p #$data-directory) + (chown #$data-directory (passwd:uid user) (passwd:gid user)) + + ;; Drop privileges and init state directory in a new + ;; process. Wait for it to finish before proceeding. + (match (primitive-fork) + (0 + ;; Exit with a non-zero status code if an exception is thrown. + (dynamic-wind + (const #t) + (lambda () + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + (primitive-exit (system* initdb "-D" #$data-directory))) + (lambda () + (primitive-exit 1)))) + (pid (waitpid pid)))))))) + +(define postgresql-dmd-service + (match-lambda + (($ <postgresql-configuration> postgresql config-file data-directory) + (let ((start-script + ;; Wrapper script that switches to the 'postgres' user before + ;; launching daemon. + (program-file "start-postgres" + #~(let ((user (getpwnam "postgres")) + (postgres (string-append #$postgresql + "/bin/postgres"))) + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + (system* postgres + (string-append "--config-file=" + #$config-file) + "-D" #$data-directory))))) + (list (dmd-service + (provision '(postgres)) + (documentation "Run the PostgreSQL daemon.") + (requirement '(user-processes loopback)) + (start #~(make-forkexec-constructor #$start-script)) + (stop #~(make-kill-destructor)))))))) + +(define postgresql-service-type + (service-type (name 'postgresql) + (extensions + (list (service-extension dmd-root-service-type + postgresql-dmd-service) + (service-extension activation-service-type + postgresql-activation) + (service-extension account-service-type + (const %postgresql-accounts)))))) (define* (postgresql-service #:key (postgresql postgresql) (config-file %default-postgres-config) @@ -59,63 +136,8 @@ host all all ::1/128 trust")) The PostgreSQL daemon loads its runtime configuration from @var{config-file} and stores the database cluster in @var{data-directory}." - ;; Wrapper script that switches to the 'postgres' user before launching - ;; daemon. - (define start-script - (mlet %store-monad ((config-file config-file)) - (gexp->script "start-postgres" - #~(let ((user (getpwnam "postgres")) - (postgres (string-append #$postgresql - "/bin/postgres"))) - (setgid (passwd:gid user)) - (setuid (passwd:uid user)) - (system* postgres - (string-append "--config-file=" #$config-file) - "-D" #$data-directory))))) - - (define activate - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (let ((user (getpwnam "postgres")) - (initdb (string-append #$postgresql "/bin/initdb"))) - ;; Create db state directory. - (mkdir-p #$data-directory) - (chown #$data-directory (passwd:uid user) (passwd:gid user)) - - ;; Drop privileges and init state directory in a new - ;; process. Wait for it to finish before proceeding. - (match (primitive-fork) - (0 - ;; Exit with a non-zero status code if an exception is thrown. - (dynamic-wind - (const #t) - (lambda () - (setgid (passwd:gid user)) - (setuid (passwd:uid user)) - (primitive-exit (system* initdb "-D" #$data-directory))) - (lambda () - (primitive-exit 1)))) - (pid (waitpid pid)))))) - - (mlet %store-monad ((start-script start-script)) - (return - (service - (provision '(postgres)) - (documentation "Run the PostgreSQL daemon.") - (requirement '(user-processes loopback)) - (start #~(make-forkexec-constructor #$start-script)) - (stop #~(make-kill-destructor)) - (activate activate) - (user-groups (list (user-group - (name "postgres") - (system? #t)))) - (user-accounts (list (user-account - (name "postgres") - (group "postgres") - (system? #t) - (comment "PostgreSQL server user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (service postgresql-service-type + (postgresql-configuration + (postgresql postgresql) + (config-file config-file) + (data-directory data-directory)))) diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm new file mode 100644 index 0000000000..e4ecd961c5 --- /dev/null +++ b/gnu/services/dbus.scm @@ -0,0 +1,178 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services dbus) + #:use-module (gnu services) + #:use-module (gnu services dmd) + #:use-module (gnu system shadow) + #:use-module (gnu packages glib) + #:use-module (gnu packages admin) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (dbus-root-service-type + dbus-service)) + +;;; +;;; D-Bus. +;;; + +(define-record-type* <dbus-configuration> + dbus-configuration make-dbus-configuration + dbus-configuration? + (dbus dbus-configuration-dbus ;<package> + (default dbus)) + (services dbus-configuration-services ;list of <package> + (default '()))) + +(define (dbus-configuration-directory dbus services) + "Return a configuration directory for @var{dbus} that includes the +@code{etc/dbus-1/system.d} directories of each package listed in +@var{services}." + (define build + #~(begin + (use-modules (sxml simple) + (srfi srfi-1)) + + (define (services->sxml services) + ;; Return the SXML 'includedir' clauses for DIRS. + `(busconfig + ,@(append-map (lambda (dir) + `((includedir + ,(string-append dir "/etc/dbus-1/system.d")) + (servicedir ;for '.service' files + ,(string-append dir "/share/dbus-1/services")) + (servicedir ;likewise, for auto-activation + ,(string-append + dir + "/share/dbus-1/system-services")))) + services))) + + (mkdir #$output) + (copy-file (string-append #$dbus "/etc/dbus-1/system.conf") + (string-append #$output "/system.conf")) + + ;; The default 'system.conf' has an <includedir> clause for + ;; 'system.d', so create it. + (mkdir (string-append #$output "/system.d")) + + ;; 'system-local.conf' is automatically included by the default + ;; 'system.conf', so this is where we stuff our own things. + (call-with-output-file (string-append #$output "/system-local.conf") + (lambda (port) + (sxml->xml (services->sxml (list #$@services)) + port))))) + + (computed-file "dbus-configuration" build)) + +(define %dbus-accounts + ;; Accounts used by the system bus. + (list (user-group (name "messagebus") (system? #t)) + (user-account + (name "messagebus") + (group "messagebus") + (system? #t) + (comment "D-Bus system bus user") + (home-directory "/var/run/dbus") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define (dbus-activation config) + "Return an activation gexp for D-Bus using @var{config}." + #~(begin + (use-modules (guix build utils)) + + (mkdir-p "/var/run/dbus") + + (let ((user (getpwnam "messagebus"))) + (chown "/var/run/dbus" + (passwd:uid user) (passwd:gid user))) + + (unless (file-exists? "/etc/machine-id") + (format #t "creating /etc/machine-id...~%") + (let ((prog (string-append #$(dbus-configuration-dbus config) + "/bin/dbus-uuidgen"))) + ;; XXX: We can't use 'system' because the initrd's + ;; guile system(3) only works when 'sh' is in $PATH. + (let ((pid (primitive-fork))) + (if (zero? pid) + (call-with-output-file "/etc/machine-id" + (lambda (port) + (close-fdes 1) + (dup2 (port->fdes port) 1) + (execl prog))) + (waitpid pid))))))) + +(define dbus-dmd-service + (match-lambda + (($ <dbus-configuration> dbus services) + (let ((conf (dbus-configuration-directory dbus services))) + (list (dmd-service + (documentation "Run the D-Bus system daemon.") + (provision '(dbus-system)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$dbus "/bin/dbus-daemon") + "--nofork" + (string-append "--config-file=" #$conf + "/system.conf")))) + (stop #~(make-kill-destructor)))))))) + +(define dbus-root-service-type + (service-type (name 'dbus) + (extensions + (list (service-extension dmd-root-service-type + dbus-dmd-service) + (service-extension activation-service-type + dbus-activation) + (service-extension account-service-type + (const %dbus-accounts)))) + + ;; Extensions consist of lists of packages (representing D-Bus + ;; services) that we just concatenate. + ;; + ;; FIXME: We need 'dbus-daemon-launch-helper' to be + ;; setuid-root for auto-activation to work. + (compose concatenate) + + ;; The service's parameters field is extended by augmenting + ;; its <dbus-configuration> 'services' field. + (extend (lambda (config services) + (dbus-configuration + (inherit config) + (services + (append (dbus-configuration-services config) + services))))))) + +(define* (dbus-service #:key (dbus dbus) (services '())) + "Return a service that runs the \"system bus\", using @var{dbus}, with +support for @var{services}. + +@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication +facility. Its system bus is used to allow system services to communicate and +be notified of system-wide events. + +@var{services} must be a list of packages that provide an +@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration +and policy files. For example, to allow avahi-daemon to use the system bus, +@var{services} must be equal to @code{(list avahi)}." + (service dbus-root-service-type + (dbus-configuration (dbus dbus) + (services services)))) + +;;; dbus.scm ends here diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index b91bdd8ad3..69edc6d9bb 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -20,7 +20,9 @@ (define-module (gnu services desktop) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu services base) + #:use-module (gnu services dbus) #:use-module (gnu services avahi) #:use-module (gnu services xorg) #:use-module (gnu services networking) @@ -31,17 +33,14 @@ #:use-module (gnu packages freedesktop) #:use-module (gnu packages gnome) #:use-module (gnu packages avahi) - #:use-module (gnu packages wicd) #:use-module (gnu packages polkit) - #:use-module ((gnu packages linux) - #:select (lvm2 fuse alsa-utils crda)) - #:use-module (guix monads) #:use-module (guix records) + #:use-module (guix packages) #:use-module (guix store) #:use-module (guix gexp) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) - #:export (dbus-service - upower-service + #:export (upower-service colord-service geoclue-application %standard-geoclue-applications @@ -65,134 +64,133 @@ (define (bool value) (if value "true\n" "false\n")) - -;;; -;;; D-Bus. -;;; -(define (dbus-configuration-directory dbus services) - "Return a configuration directory for @var{dbus} that includes the -@code{etc/dbus-1/system.d} directories of each package listed in -@var{services}." - (define build - #~(begin - (use-modules (sxml simple) - (srfi srfi-1)) - - (define (services->sxml services) - ;; Return the SXML 'includedir' clauses for DIRS. - `(busconfig - ,@(append-map (lambda (dir) - `((includedir - ,(string-append dir "/etc/dbus-1/system.d")) - (servicedir ;for '.service' files - ,(string-append dir "/share/dbus-1/services")))) - services))) - - (mkdir #$output) - (copy-file (string-append #$dbus "/etc/dbus-1/system.conf") - (string-append #$output "/system.conf")) - - ;; The default 'system.conf' has an <includedir> clause for - ;; 'system.d', so create it. - (mkdir (string-append #$output "/system.d")) - - ;; 'system-local.conf' is automatically included by the default - ;; 'system.conf', so this is where we stuff our own things. - (call-with-output-file (string-append #$output "/system-local.conf") - (lambda (port) - (sxml->xml (services->sxml (list #$@services)) - port))))) - - (gexp->derivation "dbus-configuration" build)) - -(define* (dbus-service services #:key (dbus dbus)) - "Return a service that runs the \"system bus\", using @var{dbus}, with -support for @var{services}. - -@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication -facility. Its system bus is used to allow system services to communicate and -be notified of system-wide events. - -@var{services} must be a list of packages that provide an -@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration -and policy files. For example, to allow avahi-daemon to use the system bus, -@var{services} must be equal to @code{(list avahi)}." - (mlet %store-monad ((conf (dbus-configuration-directory dbus services))) - (return - (service - (documentation "Run the D-Bus system daemon.") - (provision '(dbus-system)) - (requirement '(user-processes)) - (start #~(make-forkexec-constructor - (list (string-append #$dbus "/bin/dbus-daemon") - "--nofork" - (string-append "--config-file=" #$conf "/system.conf")))) - (stop #~(make-kill-destructor)) - (user-groups (list (user-group - (name "messagebus") - (system? #t)))) - (user-accounts (list (user-account - (name "messagebus") - (group "messagebus") - (system? #t) - (comment "D-Bus system bus user") - (home-directory "/var/run/dbus") - (shell - #~(string-append #$shadow "/sbin/nologin"))))) - (activate #~(begin - (use-modules (guix build utils)) - - (mkdir-p "/var/run/dbus") - - (let ((user (getpwnam "messagebus"))) - (chown "/var/run/dbus" - (passwd:uid user) (passwd:gid user))) - - (unless (file-exists? "/etc/machine-id") - (format #t "creating /etc/machine-id...~%") - (let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) - ;; XXX: We can't use 'system' because the initrd's - ;; guile system(3) only works when 'sh' is in $PATH. - (let ((pid (primitive-fork))) - (if (zero? pid) - (call-with-output-file "/etc/machine-id" - (lambda (port) - (close-fdes 1) - (dup2 (port->fdes port) 1) - (execl prog))) - (waitpid pid))))))))))) +(define (wrapped-dbus-service service program variable value) + "Return a wrapper for @var{service}, a package containing a D-Bus service, +where @var{program} is wrapped such that environment variable @var{variable} +is set to @var{value} when the bus daemon launches it." + (define wrapper + (program-file (string-append (package-name service) "-program-wrapper") + #~(begin + (setenv #$variable #$value) + (apply execl (string-append #$service "/" #$program) + (string-append #$service "/" #$program) + (cdr (command-line)))))) + + (computed-file (string-append (package-name service) "-wrapper") + #~(begin + (use-modules (guix build utils)) + + (define service-directory + "/share/dbus-1/system-services") + + (mkdir-p (dirname (string-append #$output + service-directory))) + (copy-recursively (string-append #$service + service-directory) + (string-append #$output + service-directory)) + (symlink (string-append #$service "/etc") ;for etc/dbus-1 + (string-append #$output "/etc")) + + (for-each (lambda (file) + (substitute* file + (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" + _ original-program arguments) + (string-append "Exec=" #$wrapper arguments + "\n")))) + (find-files #$output "\\.service$"))) + #:modules '((guix build utils)))) ;;; ;;; Upower D-Bus service. ;;; -(define* (upower-configuration-file #:key watts-up-pro? poll-batteries? - ignore-lid? use-percentage-for-policy? - percentage-low percentage-critical - percentage-action time-low - time-critical time-action - critical-power-action) - "Return an upower-daemon configuration file." - (text-file "UPower.conf" - (string-append - "[UPower]\n" - "EnableWattsUpPro=" (bool watts-up-pro?) - "NoPollBatteries=" (bool (not poll-batteries?)) - "IgnoreLid=" (bool ignore-lid?) - "UsePercentageForPolicy=" (bool use-percentage-for-policy?) - "PercentageLow=" (number->string percentage-low) "\n" - "PercentageCritical=" (number->string percentage-critical) "\n" - "PercentageAction=" (number->string percentage-action) "\n" - "TimeLow=" (number->string time-low) "\n" - "TimeCritical=" (number->string time-critical) "\n" - "TimeAction=" (number->string time-action) "\n" - "CriticalPowerAction=" (match critical-power-action - ('hybrid-sleep "HybridSleep") - ('hibernate "Hibernate") - ('power-off "PowerOff")) - "\n"))) +;; TODO: Export. +(define-record-type* <upower-configuration> + upower-configuration make-upower-configuration + upower-configuration? + (upower upower-configuration-upower + (default upower)) + (watts-up-pro? upower-configuration-watts-up-pro?) + (poll-batteries? upower-configuration-poll-batteries?) + (ignore-lid? upower-configuration-ignore-lid?) + (use-percentage-for-policy? upower-configuration-use-percentage-for-policy?) + (percentage-low upower-configuration-percentage-low) + (percentage-critical upower-configuration-percentage-critical) + (percentage-action upower-configuration-percentage-action) + (time-low upower-configuration-time-low) + (time-critical upower-configuration-time-critical) + (time-action upower-configuration-time-action) + (critical-power-action upower-configuration-critical-power-action)) + +(define* upower-configuration-file + ;; Return an upower-daemon configuration file. + (match-lambda + (($ <upower-configuration> upower + watts-up-pro? poll-batteries? ignore-lid? use-percentage-for-policy? + percentage-low percentage-critical percentage-action time-low + time-critical time-action critical-power-action) + (plain-file "UPower.conf" + (string-append + "[UPower]\n" + "EnableWattsUpPro=" (bool watts-up-pro?) + "NoPollBatteries=" (bool (not poll-batteries?)) + "IgnoreLid=" (bool ignore-lid?) + "UsePercentageForPolicy=" (bool use-percentage-for-policy?) + "PercentageLow=" (number->string percentage-low) "\n" + "PercentageCritical=" (number->string percentage-critical) "\n" + "PercentageAction=" (number->string percentage-action) "\n" + "TimeLow=" (number->string time-low) "\n" + "TimeCritical=" (number->string time-critical) "\n" + "TimeAction=" (number->string time-action) "\n" + "CriticalPowerAction=" (match critical-power-action + ('hybrid-sleep "HybridSleep") + ('hibernate "Hibernate") + ('power-off "PowerOff")) + "\n"))))) + +(define %upower-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/upower"))) + +(define (upower-dbus-service config) + (list (wrapped-dbus-service (upower-configuration-upower config) + "libexec/upowerd" + "UPOWER_CONF_FILE_NAME" + (upower-configuration-file config)))) + +(define (upower-dmd-service config) + "Return a dmd service for UPower with CONFIG." + (let ((upower (upower-configuration-upower config)) + (config (upower-configuration-file config))) + (list (dmd-service + (documentation "Run the UPower power and battery monitor.") + (provision '(upower-daemon)) + (requirement '(dbus-system udev)) + + (start #~(make-forkexec-constructor + (list (string-append #$upower "/libexec/upowerd")) + #:environment-variables + (list (string-append "UPOWER_CONF_FILE_NAME=" + #$config)))) + (stop #~(make-kill-destructor)))))) + +(define upower-service-type + (service-type (name 'upower) + (extensions + (list (service-extension dbus-root-service-type + upower-dbus-service) + (service-extension dmd-root-service-type + upower-dmd-service) + (service-extension activation-service-type + (const %upower-activation)) + (service-extension udev-service-type + (compose + list + upower-configuration-upower)))))) (define* (upower-service #:key (upower upower) (watts-up-pro? #f) @@ -210,93 +208,97 @@ and policy files. For example, to allow avahi-daemon to use the system bus, @command{upowerd}}, a system-wide monitor for power consumption and battery levels, with the given configuration settings. It implements the @code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME." - (mlet %store-monad ((config (upower-configuration-file - #:watts-up-pro? watts-up-pro? - #:poll-batteries? poll-batteries? - #:ignore-lid? ignore-lid? - #:use-percentage-for-policy? use-percentage-for-policy? - #:percentage-low percentage-low - #:percentage-critical percentage-critical - #:percentage-action percentage-action - #:time-low time-low - #:time-critical time-critical - #:time-action time-action - #:critical-power-action critical-power-action))) - (return - (service - (documentation "Run the UPower power and battery monitor.") - (provision '(upower-daemon)) - (requirement '(dbus-system udev)) - - (start #~(make-forkexec-constructor - (list (string-append #$upower "/libexec/upowerd")) - #:environment-variables - (list (string-append "UPOWER_CONF_FILE_NAME=" #$config)))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/lib/upower") - (let ((user (getpwnam "upower"))) - (chown "/var/lib/upower" - (passwd:uid user) (passwd:gid user))))) - - (user-groups (list (user-group - (name "upower") - (system? #t)))) - (user-accounts (list (user-account - (name "upower") - (group "upower") - (system? #t) - (comment "UPower daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (let ((config (upower-configuration + (watts-up-pro? watts-up-pro?) + (poll-batteries? poll-batteries?) + (ignore-lid? ignore-lid?) + (use-percentage-for-policy? use-percentage-for-policy?) + (percentage-low percentage-low) + (percentage-critical percentage-critical) + (percentage-action percentage-action) + (time-low time-low) + (time-critical time-critical) + (time-action time-action) + (critical-power-action critical-power-action)))) + (service upower-service-type config))) ;;; ;;; Colord D-Bus service. ;;; +(define %colord-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/colord") + (let ((user (getpwnam "colord"))) + (chown "/var/lib/colord" + (passwd:uid user) (passwd:gid user))))) + +(define %colord-accounts + (list (user-group (name "colord") (system? #t)) + (user-account + (name "colord") + (group "colord") + (system? #t) + (comment "colord daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define (colord-dmd-service colord) + "Return a dmd service for COLORD." + ;; TODO: Remove when D-Bus activation works. + (list (dmd-service + (documentation "Run the colord color management service.") + (provision '(colord-daemon)) + (requirement '(dbus-system udev)) + (start #~(make-forkexec-constructor + (list (string-append #$colord "/libexec/colord")))) + (stop #~(make-kill-destructor))))) + +(define colord-service-type + (service-type (name 'colord) + (extensions + (list (service-extension account-service-type + (const %colord-accounts)) + (service-extension activation-service-type + (const %colord-activation)) + (service-extension dmd-root-service-type + colord-dmd-service) + + ;; Colord is a D-Bus service that dbus-daemon can + ;; activate. + (service-extension dbus-root-service-type list) + + ;; Colord provides "color device" rules for udev. + (service-extension udev-service-type list))))) + (define* (colord-service #:key (colord colord)) "Return a service that runs @command{colord}, a system service with a D-Bus interface to manage the color profiles of input and output devices such as screens and scanners. It is notably used by the GNOME Color Manager graphical tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web site} for more information." - (with-monad %store-monad - (return - (service - (documentation "Run the colord color management service.") - (provision '(colord-daemon)) - (requirement '(dbus-system udev)) - - (start #~(make-forkexec-constructor - (list (string-append #$colord "/libexec/colord")))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/lib/colord") - (let ((user (getpwnam "colord"))) - (chown "/var/lib/colord" - (passwd:uid user) (passwd:gid user))))) - - (user-groups (list (user-group - (name "colord") - (system? #t)))) - (user-accounts (list (user-account - (name "colord") - (group "colord") - (system? #t) - (comment "colord daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (service colord-service-type colord)) ;;; ;;; GeoClue D-Bus service. ;;; +;; TODO: Export. +(define-record-type* <geoclue-configuration> + geoclue-configuration make-geoclue-configuration + geoclue-configuration? + (geoclue geoclue-configuration-geoclue + (default geoclue)) + (whitelist geoclue-configuration-whitelist) + (wifi-geolocation-url geoclue-configuration-wifi-geolocation-url) + (submit-data? geoclue-configuration-submit-data?) + (wifi-submission-url geoclue-configuration-wifi-submission-url) + (submission-nick geoclue-configuration-submission-nick) + (applications geoclue-configuration-applications)) + (define* (geoclue-application name #:key (allowed? #t) system? (users '())) "Configure default GeoClue access permissions for an application. NAME is the Desktop ID of the application, without the .desktop part. If ALLOWED? is @@ -316,21 +318,67 @@ users are allowed." (geoclue-application "epiphany" #:system? #f) (geoclue-application "firefox" #:system? #f))) -(define* (geoclue-configuration-file #:key whitelist wifi-geolocation-url - submit-data? - wifi-submission-url submission-nick - applications) +(define* (geoclue-configuration-file config) "Return a geoclue configuration file." - (text-file "geoclue.conf" - (string-append - "[agent]\n" - "whitelist=" (string-join whitelist ";") "\n" - "[wifi]\n" - "url=" wifi-geolocation-url "\n" - "submit-data=" (bool submit-data?) - "submission-url=" wifi-submission-url "\n" - "submission-nick=" submission-nick "\n" - (string-join applications "\n")))) + (plain-file "geoclue.conf" + (string-append + "[agent]\n" + "whitelist=" + (string-join (geoclue-configuration-whitelist config) + ";") "\n" + "[wifi]\n" + "url=" (geoclue-configuration-wifi-geolocation-url config) "\n" + "submit-data=" (bool (geoclue-configuration-submit-data? config)) + "submission-url=" + (geoclue-configuration-wifi-submission-url config) "\n" + "submission-nick=" + (geoclue-configuration-submission-nick config) + "\n" + (string-join (geoclue-configuration-applications config) + "\n")))) + +(define (geoclue-dbus-service config) + (list (wrapped-dbus-service (geoclue-configuration-geoclue config) + "libexec/geoclue" + "GEOCLUE_CONFIG_FILE" + (geoclue-configuration-file config)))) + +(define (geoclue-dmd-service config) + "Return a GeoClue dmd service for CONFIG." + ;; TODO: Remove when D-Bus activation works. + (let ((geoclue (geoclue-configuration-geoclue config)) + (config (geoclue-configuration-file config))) + (list (dmd-service + (documentation "Run the GeoClue location service.") + (provision '(geoclue-daemon)) + (requirement '(dbus-system)) + + (start #~(make-forkexec-constructor + (list (string-append #$geoclue "/libexec/geoclue")) + #:user "geoclue" + #:environment-variables + (list (string-append "GEOCLUE_CONFIG_FILE=" #$config)))) + (stop #~(make-kill-destructor)))))) + +(define %geoclue-accounts + (list (user-group (name "geoclue") (system? #t)) + (user-account + (name "geoclue") + (group "geoclue") + (system? #t) + (comment "GeoClue daemon user") + (home-directory "/var/empty") + (shell "/run/current-system/profile/sbin/nologin")))) + +(define geoclue-service-type + (service-type (name 'geoclue) + (extensions + (list (service-extension dbus-root-service-type + geoclue-dbus-service) + (service-extension dmd-root-service-type + geoclue-dmd-service) + (service-extension account-service-type + (const %geoclue-accounts)))))) (define* (geoclue-service #:key (geoclue geoclue) (whitelist '()) @@ -350,73 +398,67 @@ and Epiphany web browsers are able to ask for the user's location, and in the case of Icecat and Epiphany, both will ask the user for permission first. See @uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web site} for more information." - (mlet %store-monad ((config (geoclue-configuration-file - #:whitelist whitelist - #:wifi-geolocation-url wifi-geolocation-url - #:submit-data? submit-data? - #:wifi-submission-url wifi-submission-url - #:submission-nick submission-nick - #:applications applications))) - (return - (service - (documentation "Run the GeoClue location service.") - (provision '(geoclue-daemon)) - (requirement '(dbus-system)) - - (start #~(make-forkexec-constructor - (list (string-append #$geoclue "/libexec/geoclue")) - #:user "geoclue" - #:environment-variables - (list (string-append "GEOCLUE_CONFIG_FILE=" #$config)))) - (stop #~(make-kill-destructor)) - - (user-groups (list (user-group - (name "geoclue") - (system? #t)))) - (user-accounts (list (user-account - (name "geoclue") - (group "geoclue") - (system? #t) - (comment "GeoClue daemon user") - (home-directory "/var/empty") - (shell - "/run/current-system/profile/sbin/nologin")))))))) + (service geoclue-service-type + (geoclue-configuration + (geoclue geoclue) + (whitelist whitelist) + (wifi-geolocation-url wifi-geolocation-url) + (submit-data? submit-data?) + (wifi-submission-url wifi-submission-url) + (submission-nick submission-nick) + (applications applications)))) ;;; ;;; Polkit privilege management service. ;;; +(define %polkit-accounts + (list (user-group (name "polkitd") (system? #t)) + (user-account + (name "polkitd") + (group "polkitd") + (system? #t) + (comment "Polkit daemon user") + (home-directory "/var/empty") + (shell "/run/current-system/profile/sbin/nologin")))) + +(define %polkit-pam-services + (list (unix-pam-service "polkitd"))) + +(define (polkit-dmd-service polkit) + "Return the <dmd-service> for POLKIT." + ;; TODO: Remove when D-Bus activation works. + (list (dmd-service + (documentation "Run the polkit privilege management service.") + (provision '(polkit-daemon)) + (requirement '(dbus-system)) + + (start #~(make-forkexec-constructor + (list (string-append #$polkit "/lib/polkit-1/polkitd")))) + (stop #~(make-kill-destructor))))) + +(define polkit-service-type + ;; TODO: Make it extensible so it can collect policy files from other + ;; services. + (service-type (name 'polkit) + (extensions + (list (service-extension account-service-type + (const %polkit-accounts)) + (service-extension pam-root-service-type + (const %polkit-pam-services)) + (service-extension dbus-root-service-type + list) + (service-extension dmd-root-service-type + polkit-dmd-service))))) + (define* (polkit-service #:key (polkit polkit)) "Return a service that runs the @command{polkit} privilege management service. By querying the @command{polkit} service, a privileged system component can know when it should grant additional capabilities to ordinary users. For example, an ordinary user can be granted the capability to suspend the system if the user is logged in locally." - (with-monad %store-monad - (return - (service - (documentation "Run the polkit privilege management service.") - (provision '(polkit-daemon)) - (requirement '(dbus-system)) - - (start #~(make-forkexec-constructor - (list (string-append #$polkit "/lib/polkit-1/polkitd")))) - (stop #~(make-kill-destructor)) - - (user-groups (list (user-group - (name "polkitd") - (system? #t)))) - (user-accounts (list (user-account - (name "polkitd") - (group "polkitd") - (system? #t) - (comment "Polkit daemon user") - (home-directory "/var/empty") - (shell - "/run/current-system/profile/sbin/nologin")))) - - (pam-services (list (unix-pam-service "polkit-1"))))))) + (service polkit-service-type polkit)) ;;; @@ -426,6 +468,8 @@ the system if the user is logged in locally." (define-record-type* <elogind-configuration> elogind-configuration make-elogind-configuration elogind-configuration + (elogind elogind-package + (default elogind)) (kill-user-processes? elogind-kill-user-processes? (default #f)) (kill-only-users elogind-kill-only-users @@ -520,7 +564,7 @@ the system if the user is logged in locally." ((_ config str) (string-append str "\n")))) (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 config "logind.conf" "[Login]" @@ -555,69 +599,62 @@ the system if the user is logged in locally." ("HybridSleepState" (sleep-list elogind-hybrid-sleep-state)) ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode)))) -(define* (elogind-service #:key (elogind elogind) - (config (elogind-configuration))) +(define (elogind-dmd-service config) + "Return a dmd service for elogind, using @var{config}." + (let ((config-file (elogind-configuration-file config)) + (elogind (elogind-package config))) + (list (dmd-service + (documentation "Run the elogind login and seat management service.") + (provision '(elogind)) + (requirement '(dbus-system)) + + (start #~(make-forkexec-constructor + (list (string-append #$elogind "/libexec/elogind/elogind")) + #:environment-variables + (list (string-append "ELOGIND_CONF_FILE=" #$config-file)))) + (stop #~(make-kill-destructor)))))) + +(define elogind-service-type + (service-type (name 'elogind) + (extensions + (list (service-extension dmd-root-service-type + elogind-dmd-service) + (service-extension dbus-root-service-type + (compose list elogind-package)) + (service-extension udev-service-type + (compose list elogind-package)) + ;; TODO: Extend polkit(?) and PAM. + )))) + +(define* (elogind-service #:key (config (elogind-configuration))) "Return a service that runs the @command{elogind} login and seat management service. The @command{elogind} service integrates with PAM to allow other system components to know the set of logged-in users as well as their session types (graphical, console, remote, etc.). It can also clean up after users when they log out." - (mlet %store-monad ((config-file (elogind-configuration-file config))) - (return - (service - (documentation "Run the elogind login and seat management service.") - (provision '(elogind)) - (requirement '(dbus-system)) - - (start #~(make-forkexec-constructor - (list (string-append #$elogind "/libexec/elogind/elogind")) - #:environment-variables - (list (string-append "ELOGIND_CONF_FILE=" #$config-file)))) - (stop #~(make-kill-destructor)))))) + (service elogind-service-type config)) ;;; ;;; The default set of desktop services. ;;; + (define %desktop-services ;; List of services typically useful for a "desktop" use case. (cons* (slim-service) + ;; The D-Bus clique. (avahi-service) (wicd-service) (upower-service) - ;; FIXME: The colord, geoclue, and polkit services could all be - ;; bus-activated by default, so they don't run at program startup. - ;; However, user creation and /var/lib/colord creation happen at - ;; service activation time, so we currently add them to the set of - ;; default services. (colord-service) (geoclue-service) (polkit-service) (elogind-service) - (dbus-service (list avahi wicd upower colord geoclue polkit elogind)) + (dbus-service) (ntp-service) - (map (lambda (mservice) - (mlet %store-monad ((service mservice)) - (cond - ;; Provide an nscd ready to use nss-mdns. - ((memq 'nscd (service-provision service)) - (nscd-service (nscd-configuration) - #:name-services (list nss-mdns))) - - ;; Add more rules to udev-service. - ;; - ;; XXX Keep this in sync with the 'udev-service' call in - ;; %base-services. Here we intend only to add 'upower', - ;; 'colord', and 'elogind'. - ((memq 'udev (service-provision service)) - (udev-service #:rules - (list lvm2 fuse alsa-utils crda - upower colord elogind))) - - (else mservice)))) - %base-services))) + %base-services)) ;;; desktop.scm ends here diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 618df91c5e..6020ffc8eb 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -22,13 +22,27 @@ #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix records) #:use-module (guix derivations) ;imported-modules, etc. #:use-module (gnu services) + #:use-module (gnu packages admin) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:export (dmd-configuration-file)) + #:export (dmd-root-service-type + %dmd-root-service + dmd-service-type + + dmd-service + dmd-service? + dmd-service-documentation + dmd-service-provision + dmd-service-requirement + dmd-service-respawn? + dmd-service-start + dmd-service-stop + dmd-service-auto-start?)) ;;; Commentary: ;;; @@ -36,6 +50,68 @@ ;;; ;;; Code: + +(define (dmd-boot-gexp services) + (mlet %store-monad ((dmd-conf (dmd-configuration-file services))) + (return #~(begin + ;; Keep track of the booted system. + (false-if-exception (delete-file "/run/booted-system")) + (symlink (readlink "/run/current-system") + "/run/booted-system") + + ;; Close any remaining open file descriptors to be on the safe + ;; side. This must be the very last thing we do, because + ;; Guile has internal FDs such as 'sleep_pipe' that need to be + ;; alive. + (let loop ((fd 3)) + (when (< fd 1024) + (false-if-exception (close-fdes fd)) + (loop (+ 1 fd)))) + + ;; Start dmd. + (execl (string-append #$dmd "/bin/dmd") + "dmd" "--config" #$dmd-conf))))) + +(define dmd-root-service-type + (service-type + (name 'dmd-root) + ;; Extending the root dmd service (aka. PID 1) happens by concatenating the + ;; list of services provided by the extensions. + (compose concatenate) + (extend append) + (extensions (list (service-extension boot-service-type dmd-boot-gexp))))) + +(define %dmd-root-service + ;; The root dmd service, aka. PID 1. Its parameter is a list of + ;; <dmd-service> objects. + (service dmd-root-service-type '())) + +(define-syntax-rule (dmd-service-type proc) + "Return a <service-type> denoting a simple dmd service--i.e., the type for a +service that extends DMD-ROOT-SERVICE-TYPE and nothing else." + (service-type + (name 'some-dmd-service) + (extensions + (list (service-extension dmd-root-service-type + (compose list proc)))))) + +(define-record-type* <dmd-service> + dmd-service make-dmd-service + dmd-service? + (documentation service-documentation ; string + (default "[No documentation.]")) + (provision service-provision) ; list of symbols + (requirement service-requirement ; list of symbols + (default '())) + (respawn? service-respawn? ; Boolean + (default #t)) + (start service-start) ; g-expression (procedure) + (stop service-stop ; g-expression (procedure) + (default #~(const #f))) + (auto-start? service-auto-start? ; Boolean + (default #t))) + + (define (assert-no-duplicates services) "Raise an error if SERVICES provide the same dmd service more than once. diff --git a/gnu/services/lirc.scm b/gnu/services/lirc.scm index 857f362db7..6ae622579d 100644 --- a/gnu/services/lirc.scm +++ b/gnu/services/lirc.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,18 +19,65 @@ (define-module (gnu services lirc) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu packages lirc) - #:use-module (guix monads) - #:use-module (guix store) #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (ice-9 match) #:export (lirc-service)) ;;; Commentary: ;;; -;;; LIRC services. +;;; LIRC service. ;;; ;;; Code: +(define-record-type* <lirc-configuration> + lirc-configuration make-lirc-configuration + lirc-configuation? + (lirc lirc-configuration-lirc ;<package> + (default lirc)) + (device lirc-configuration-device) ;string + (driver lirc-configuration-driver) ;string + (config-file lirc-configuration-file) ;string | file-like object + (extra-options lirc-configuration-options ;list of strings + (default '()))) + +(define %lirc-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/lirc"))) + +(define lirc-dmd-service + (match-lambda + (($ <lirc-configuration> lirc device driver config-file options) + (list (dmd-service + (provision '(lircd)) + (documentation "Run the LIRC daemon.") + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$lirc "/sbin/lircd") + "--nodaemon" + #$@(if device + #~("--device" #$device) + #~()) + #$@(if driver + #~("--driver" #$driver) + #~()) + #$@(if config-file + #~(#$config-file) + #~()) + #$@options))) + (stop #~(make-kill-destructor))))))) + +(define lirc-service-type + (service-type (name 'lirc) + (extensions + (list (service-extension dmd-root-service-type + lirc-dmd-service) + (service-extension activation-service-type + (const %lirc-activation)))))) + (define* (lirc-service #:key (lirc lirc) device driver config-file (extra-options '())) @@ -41,28 +89,11 @@ The daemon will use specified @var{device}, @var{driver} and Finally, @var{extra-options} is a list of additional command-line options passed to @command{lircd}." - (with-monad %store-monad - (return - (service - (provision '(lircd)) - (documentation "Run the LIRC daemon.") - (requirement '(user-processes)) - (start #~(make-forkexec-constructor - (list (string-append #$lirc "/sbin/lircd") - "--nodaemon" - #$@(if device - #~("--device" #$device) - #~()) - #$@(if driver - #~("--driver" #$driver) - #~()) - #$@(if config-file - #~(#$config-file) - #~()) - #$@extra-options))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/lirc"))))))) + (service lirc-service-type + (lirc-configuration + (lirc lirc) + (device device) (driver driver) + (config-file config-file) + (extra-options extra-options)))) ;;; lirc.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index c2b404503e..52a843b54b 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -19,7 +19,10 @@ (define-module (gnu services networking) #:use-module (gnu services) + #:use-module (gnu services dmd) + #:use-module (gnu services dbus) #:use-module (gnu system shadow) + #:use-module (gnu system linux) ;PAM #:use-module (gnu packages admin) #:use-module (gnu packages linux) #:use-module (gnu packages tor) @@ -27,9 +30,9 @@ #:use-module (gnu packages ntp) #:use-module (gnu packages wicd) #:use-module (guix gexp) - #:use-module (guix store) - #:use-module (guix monads) + #:use-module (guix records) #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:export (%facebook-host-aliases static-networking-service dhcp-client-service @@ -79,6 +82,72 @@ fe80::1%lo0 www.connect.facebook.net fe80::1%lo0 apps.facebook.com\n") +(define-record-type* <static-networking> + static-networking make-static-networking + static-networking? + (interface static-networking-interface) + (ip static-networking-ip) + (gateway static-networking-gateway) + (provision static-networking-provision) + (name-servers static-networking-name-servers) + (net-tools static-networking-net-tools)) + +(define static-networking-service-type + (dmd-service-type + (match-lambda + (($ <static-networking> interface ip gateway provision + name-servers net-tools) + (let ((loopback? (memq 'loopback provision))) + + ;; TODO: Eventually replace 'route' with bindings for the appropriate + ;; ioctls. + (dmd-service + + ;; Unless we're providing the loopback interface, wait for udev to be up + ;; and running so that INTERFACE is actually usable. + (requirement (if loopback? '() '(udev))) + + (documentation + "Bring up the networking interface using a static IP address.") + (provision provision) + (start #~(lambda _ + ;; Return #t if successfully started. + (let* ((addr (inet-pton AF_INET #$ip)) + (sockaddr (make-socket-address AF_INET addr 0))) + (configure-network-interface #$interface sockaddr + (logior IFF_UP + #$(if loopback? + #~IFF_LOOPBACK + 0)))) + #$(if gateway + #~(zero? (system* (string-append #$net-tools + "/sbin/route") + "add" "-net" "default" + "gw" #$gateway)) + #t) + #$(if (pair? name-servers) + #~(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + '#$name-servers))) + #t))) + (stop #~(lambda _ + ;; Return #f is successfully stopped. + (let ((sock (socket AF_INET SOCK_STREAM 0))) + (set-network-interface-flags sock #$interface 0) + (close-port sock)) + (not #$(if gateway + #~(system* (string-append #$net-tools + "/sbin/route") + "del" "-net" "default") + #t)))) + (respawn? #f))))))) + (define* (static-networking-service interface ip #:key gateway @@ -88,116 +157,70 @@ fe80::1%lo0 apps.facebook.com\n") "Return a service that starts @var{interface} with address @var{ip}. If @var{gateway} is true, it must be a string specifying the default network gateway." - (define loopback? - (memq 'loopback provision)) - - ;; TODO: Eventually replace 'route' with bindings for the appropriate - ;; ioctls. - (with-monad %store-monad - (return - (service - - ;; Unless we're providing the loopback interface, wait for udev to be up - ;; and running so that INTERFACE is actually usable. - (requirement (if loopback? '() '(udev))) - - (documentation - "Bring up the networking interface using a static IP address.") - (provision provision) + (service static-networking-service-type + (static-networking (interface interface) (ip ip) + (gateway gateway) + (provision provision) + (name-servers name-servers) + (net-tools net-tools)))) + +(define dhcp-client-service-type + (dmd-service-type + (lambda (dhcp) + (define dhclient + #~(string-append #$dhcp "/sbin/dhclient")) + + (define pid-file + "/var/run/dhclient.pid") + + (dmd-service + (documentation "Set up networking via DHCP.") + (requirement '(user-processes udev)) + + ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when + ;; networking is unavailable, but also means that the interface is not up + ;; yet when 'start' completes. To wait for the interface to be ready, one + ;; should instead monitor udev events. + (provision '(networking)) + (start #~(lambda _ - ;; Return #t if successfully started. - (let* ((addr (inet-pton AF_INET #$ip)) - (sockaddr (make-socket-address AF_INET addr 0))) - (configure-network-interface #$interface sockaddr - (logior IFF_UP - #$(if loopback? - #~IFF_LOOPBACK - 0)))) - #$(if gateway - #~(zero? (system* (string-append #$net-tools - "/sbin/route") - "add" "-net" "default" - "gw" #$gateway)) - #t) - #$(if (pair? name-servers) - #~(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - '#$name-servers))) - #t))) - (stop #~(lambda _ - ;; Return #f is successfully stopped. - (let ((sock (socket AF_INET SOCK_STREAM 0))) - (set-network-interface-flags sock #$interface 0) - (close-port sock)) - (not #$(if gateway - #~(system* (string-append #$net-tools - "/sbin/route") - "del" "-net" "default") - #t)))) - (respawn? #f))))) + ;; When invoked without any arguments, 'dhclient' discovers all + ;; non-loopback interfaces *that are up*. However, the relevant + ;; interfaces are typically down at this point. Thus we perform + ;; our own interface discovery here. + (define valid? + (negate loopback-network-interface?)) + (define ifaces + (filter valid? (all-network-interface-names))) + + ;; XXX: Make sure the interfaces are up so that 'dhclient' can + ;; actually send/receive over them. + (for-each set-network-interface-up ifaces) + + (false-if-exception (delete-file #$pid-file)) + (let ((pid (fork+exec-command + (cons* #$dhclient "-nw" + "-pf" #$pid-file ifaces)))) + (and (zero? (cdr (waitpid pid))) + (let loop () + (catch 'system-error + (lambda () + (call-with-input-file #$pid-file read)) + (lambda args + ;; 'dhclient' returned before PID-FILE was created, + ;; so try again. + (let ((errno (system-error-errno args))) + (if (= ENOENT errno) + (begin + (sleep 1) + (loop)) + (apply throw args)))))))))) + (stop #~(make-kill-destructor)))))) (define* (dhcp-client-service #:key (dhcp isc-dhcp)) "Return a service that runs @var{dhcp}, a Dynamic Host Configuration Protocol (DHCP) client, on all the non-loopback network interfaces." - - (define dhclient - #~(string-append #$dhcp "/sbin/dhclient")) - - (define pid-file - "/var/run/dhclient.pid") - - (with-monad %store-monad - (return (service - (documentation "Set up networking via DHCP.") - (requirement '(user-processes udev)) - - ;; XXX: Running with '-nw' ("no wait") avoids blocking for a - ;; minute when networking is unavailable, but also means that the - ;; interface is not up yet when 'start' completes. To wait for - ;; the interface to be ready, one should instead monitor udev - ;; events. - (provision '(networking)) - - (start #~(lambda _ - ;; When invoked without any arguments, 'dhclient' - ;; discovers all non-loopback interfaces *that are - ;; up*. However, the relevant interfaces are - ;; typically down at this point. Thus we perform our - ;; own interface discovery here. - (define valid? - (negate loopback-network-interface?)) - (define ifaces - (filter valid? (all-network-interface-names))) - - ;; XXX: Make sure the interfaces are up so that - ;; 'dhclient' can actually send/receive over them. - (for-each set-network-interface-up ifaces) - - (false-if-exception (delete-file #$pid-file)) - (let ((pid (fork+exec-command - (cons* #$dhclient "-nw" - "-pf" #$pid-file ifaces)))) - (and (zero? (cdr (waitpid pid))) - (let loop () - (catch 'system-error - (lambda () - (call-with-input-file #$pid-file read)) - (lambda args - ;; 'dhclient' returned before PID-FILE - ;; was created, so try again. - (let ((errno (system-error-errno args))) - (if (= ENOENT errno) - (begin - (sleep 1) - (loop)) - (apply throw args)))))))))) - (stop #~(make-kill-destructor)))))) + (service dhcp-client-service-type dhcp)) (define %ntp-servers ;; Default set of NTP servers. @@ -205,19 +228,30 @@ Protocol (DHCP) client, on all the non-loopback network interfaces." "1.pool.ntp.org" "2.pool.ntp.org")) -(define* (ntp-service #:key (ntp ntp) - (servers %ntp-servers)) - "Return a service that runs the daemon from @var{ntp}, the -@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will -keep the system clock synchronized with that of @var{servers}." - ;; TODO: Add authentication support. - - (define config - (string-append "driftfile /var/run/ntp.drift\n" - (string-join (map (cut string-append "server " <>) - servers) - "\n") - " + +;;; +;;; NTP. +;;; + +;; TODO: Export. +(define-record-type* <ntp-configuration> + ntp-configuration make-ntp-configuration + ntp-configuration? + (ntp ntp-configuration-ntp + (default ntp)) + (servers ntp-configuration-servers)) + +(define ntp-dmd-service + (match-lambda + (($ <ntp-configuration> ntp servers) + (let () + ;; TODO: Add authentication support. + (define config + (string-append "driftfile /var/run/ntp.drift\n" + (string-join (map (cut string-append "server " <>) + servers) + "\n") + " # Disable status queries as a workaround for CVE-2013-5211: # <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>. restrict default kod nomodify notrap nopeer noquery @@ -227,57 +261,154 @@ restrict -6 default kod nomodify notrap nopeer noquery restrict 127.0.0.1 restrict -6 ::1\n")) - (mlet %store-monad ((ntpd.conf (text-file "ntpd.conf" config))) - (return - (service - (provision '(ntpd)) - (documentation "Run the Network Time Protocol (NTP) daemon.") - (requirement '(user-processes networking)) - (start #~(make-forkexec-constructor - (list (string-append #$ntp "/bin/ntpd") "-n" - "-c" #$ntpd.conf - "-u" "ntpd"))) - (stop #~(make-kill-destructor)) - (user-accounts (list (user-account - (name "ntpd") - (group "nogroup") - (system? #t) - (comment "NTP daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (define ntpd.conf + (plain-file "ntpd.conf" config)) + + (list (dmd-service + (provision '(ntpd)) + (documentation "Run the Network Time Protocol (NTP) daemon.") + (requirement '(user-processes networking)) + (start #~(make-forkexec-constructor + (list (string-append #$ntp "/bin/ntpd") "-n" + "-c" #$ntpd.conf "-u" "ntpd"))) + (stop #~(make-kill-destructor)))))))) + +(define %ntp-accounts + (list (user-account + (name "ntpd") + (group "nogroup") + (system? #t) + (comment "NTP daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define ntp-service-type + (service-type (name 'ntp) + (extensions + (list (service-extension dmd-root-service-type + ntp-dmd-service) + (service-extension account-service-type + (const %ntp-accounts)))))) + +(define* (ntp-service #:key (ntp ntp) + (servers %ntp-servers)) + "Return a service that runs the daemon from @var{ntp}, the +@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will +keep the system clock synchronized with that of @var{servers}." + (service ntp-service-type + (ntp-configuration (ntp ntp) (servers servers)))) + + +;;; +;;; Tor. +;;; + +(define %tor-accounts + ;; User account and groups for Tor. + (list (user-group (name "tor") (system? #t)) + (user-account + (name "tor") + (group "tor") + (system? #t) + (comment "Tor daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define (tor-dmd-service tor) + "Return a <dmd-service> running TOR." + (let ((torrc (plain-file "torrc" "User tor\n"))) + (list (dmd-service + (provision '(tor)) + + ;; Tor needs at least one network interface to be up, hence the + ;; dependency on 'loopback'. + (requirement '(user-processes loopback)) + + (start #~(make-forkexec-constructor + (list (string-append #$tor "/bin/tor") "-f" #$torrc))) + (stop #~(make-kill-destructor)) + (documentation "Run the Tor anonymous network overlay."))))) + +(define tor-service-type + (service-type (name 'tor) + (extensions + (list (service-extension dmd-root-service-type + tor-dmd-service) + (service-extension account-service-type + (const %tor-accounts)))))) (define* (tor-service #:key (tor tor)) "Return a service to run the @uref{https://torproject.org,Tor} daemon. The daemon runs with the default settings (in particular the default exit policy) as the @code{tor} unprivileged user." - (mlet %store-monad ((torrc (text-file "torrc" "User tor\n"))) - (return - (service - (provision '(tor)) - - ;; Tor needs at least one network interface to be up, hence the - ;; dependency on 'loopback'. - (requirement '(user-processes loopback)) - - (start #~(make-forkexec-constructor - (list (string-append #$tor "/bin/tor") "-f" #$torrc))) - (stop #~(make-kill-destructor)) - - (user-groups (list (user-group - (name "tor") - (system? #t)))) - (user-accounts (list (user-account - (name "tor") - (group "tor") - (system? #t) - (comment "Tor daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))) - - (documentation "Run the Tor anonymous network overlay."))))) + (service tor-service-type tor)) + + +;;; +;;; BitlBee. +;;; + +(define-record-type* <bitlbee-configuration> + bitlbee-configuration make-bitlbee-configuration + bitlbee-configuration? + (bitlbee bitlbee-configuration-bitlbee + (default bitlbee)) + (interface bitlbee-configuration-interface) + (port bitlbee-configuration-port) + (extra-settings bitlbee-configuration-extra-settings)) + +(define bitlbee-dmd-service + (match-lambda + (($ <bitlbee-configuration> bitlbee interface port extra-settings) + (let ((conf (plain-file "bitlbee.conf" + (string-append " + [settings] + User = bitlbee + ConfigDir = /var/lib/bitlbee + DaemonInterface = " interface " + DaemonPort = " (number->string port) " +" extra-settings)))) + + (list (dmd-service + (provision '(bitlbee)) + (requirement '(user-processes loopback)) + (start #~(make-forkexec-constructor + (list (string-append #$bitlbee "/sbin/bitlbee") + "-n" "-F" "-u" "bitlbee" "-c" #$conf))) + (stop #~(make-kill-destructor)))))))) + +(define %bitlbee-accounts + ;; User group and account to run BitlBee. + (list (user-group (name "bitlbee") (system? #t)) + (user-account + (name "bitlbee") + (group "bitlbee") + (system? #t) + (comment "BitlBee daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define %bitlbee-activation + ;; Activation gexp for BitlBee. + #~(begin + (use-modules (guix build utils)) + + ;; This directory is used to store OTR data. + (mkdir-p "/var/lib/bitlbee") + (let ((user (getpwnam "bitlbee"))) + (chown "/var/lib/bitlbee" + (passwd:uid user) (passwd:gid user))))) + +(define bitlbee-service-type + (service-type (name 'bitlbee) + (extensions + (list (service-extension dmd-root-service-type + bitlbee-dmd-service) + (service-extension account-service-type + (const %bitlbee-accounts)) + (service-extension activation-service-type + (const %bitlbee-activation)))))) (define* (bitlbee-service #:key (bitlbee bitlbee) (interface "127.0.0.1") (port 6667) @@ -292,60 +423,52 @@ come from any networking interface. In addition, @var{extra-settings} specifies a string to append to the configuration file." - (mlet %store-monad ((conf (text-file "bitlbee.conf" - (string-append " - [settings] - User = bitlbee - ConfigDir = /var/lib/bitlbee - DaemonInterface = " interface " - DaemonPort = " (number->string port) " -" extra-settings)))) - (return - (service - (provision '(bitlbee)) - (requirement '(user-processes loopback)) - (activate #~(begin - (use-modules (guix build utils)) - - ;; This directory is used to store OTR data. - (mkdir-p "/var/lib/bitlbee") - (let ((user (getpwnam "bitlbee"))) - (chown "/var/lib/bitlbee" - (passwd:uid user) (passwd:gid user))))) - (start #~(make-forkexec-constructor - (list (string-append #$bitlbee "/sbin/bitlbee") - "-n" "-F" "-u" "bitlbee" "-c" #$conf))) - (stop #~(make-kill-destructor)) - (user-groups (list (user-group (name "bitlbee") (system? #t)))) - (user-accounts (list (user-account - (name "bitlbee") - (group "bitlbee") - (system? #t) - (comment "BitlBee daemon user") - (home-directory "/var/empty") - (shell #~(string-append #$shadow - "/sbin/nologin"))))))))) + (service bitlbee-service-type + (bitlbee-configuration + (bitlbee bitlbee) + (interface interface) (port port) + (extra-settings extra-settings)))) + + +;;; +;;; Wicd. +;;; + +(define %wicd-activation + ;; Activation gexp for Wicd. + #~(begin + (use-modules (guix build utils)) + + (mkdir-p "/etc/wicd") + (let ((file-name "/etc/wicd/dhclient.conf.template.default")) + (unless (file-exists? file-name) + (copy-file (string-append #$wicd file-name) + file-name))))) + +(define (wicd-dmd-service wicd) + "Return a dmd service for WICD." + (list (dmd-service + (documentation "Run the Wicd network manager.") + (provision '(networking)) + (requirement '(user-processes dbus-system loopback)) + (start #~(make-forkexec-constructor + (list (string-append #$wicd "/sbin/wicd") + "--no-daemon"))) + (stop #~(make-kill-destructor))))) + +(define wicd-service-type + (service-type (name 'wicd) + (extensions + (list (service-extension dmd-root-service-type + wicd-dmd-service) + (service-extension dbus-root-service-type + list) + (service-extension activation-service-type + (const %wicd-activation)))))) (define* (wicd-service #:key (wicd wicd)) "Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network manager that aims to simplify wired and wireless networking." - (with-monad %store-monad - (return - (service - (documentation "Run the Wicd network manager.") - (provision '(networking)) - (requirement '(user-processes dbus-system loopback)) - (start #~(make-forkexec-constructor - (list (string-append #$wicd "/sbin/wicd") - "--no-daemon"))) - (stop #~(make-kill-destructor)) - (activate - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/etc/wicd") - (let ((file-name "/etc/wicd/dhclient.conf.template.default")) - (unless (file-exists? file-name) - (copy-file (string-append #$wicd file-name) - file-name))))))))) + (service wicd-service-type wicd)) ;;; networking.scm ends here diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index e2f85421e9..d3a6cfb33a 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -18,9 +18,9 @@ (define-module (gnu services ssh) #:use-module (guix gexp) - #:use-module (guix store) - #:use-module (guix monads) + #:use-module (guix records) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu system linux) ; 'pam-service' #:use-module (gnu packages lsh) #:export (lsh-service)) @@ -31,11 +31,32 @@ ;;; ;;; Code: +;; TODO: Export. +(define-record-type* <lsh-configuration> + lsh-configuration make-lsh-configuration + lsh-configuration? + (lsh lsh-configuration-lsh + (default lsh)) + (daemonic? lsh-configuration-daemonic?) + (host-key lsh-configuration-host-key) + (interfaces lsh-configuration-interfaces) + (port-number lsh-configuration-port-number) + (allow-empty-passwords? lsh-configuration-allow-empty-passwords?) + (root-login? lsh-configuration-root-login?) + (syslog-output? lsh-configuration-syslog-output?) + (pid-file? lsh-configuration-pid-file?) + (pid-file lsh-configuration-pid-file) + (x11-forwarding? lsh-configuration-x11-forwarding?) + (tcp/ip-forwarding? lsh-configuration-tcp/ip-forwarding?) + (password-authentication? lsh-configuration-password-authentication?) + (public-key-authentication? lsh-configuration-public-key-authentication?) + (initialize? lsh-configuration-initialize?)) + (define %yarrow-seed "/var/spool/lsh/yarrow-seed-file") -(define (activation lsh host-key) - "Return the gexp to activate the LSH service for HOST-KEY." +(define (lsh-initialization lsh host-key) + "Return the gexp to initialize the LSH service for HOST-KEY." #~(begin (unless (file-exists? #$%yarrow-seed) (system* (string-append #$lsh "/bin/lsh-make-seed") @@ -71,6 +92,88 @@ (waitpid keygen) (waitpid write-key)))))))))) +(define (lsh-activation config) + "Return the activation gexp for CONFIG." + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/spool/lsh") + #$(if (lsh-configuration-initialize? config) + (lsh-initialization (lsh-configuration-lsh config) + (lsh-configuration-host-key config)) + #t))) + +(define (lsh-dmd-service config) + "Return a <dmd-service> for lsh with CONFIG." + (define lsh (lsh-configuration-lsh config)) + (define pid-file (lsh-configuration-pid-file config)) + (define pid-file? (lsh-configuration-pid-file? config)) + (define daemonic? (lsh-configuration-daemonic? config)) + (define interfaces (lsh-configuration-interfaces config)) + + (define lsh-command + (append + (cons #~(string-append #$lsh "/sbin/lshd") + (if daemonic? + (let ((syslog (if (lsh-configuration-syslog-output? config) + '() + (list "--no-syslog")))) + (cons "--daemonic" + (if pid-file? + (cons #~(string-append "--pid-file=" #$pid-file) + syslog) + (cons "--no-pid-file" syslog)))) + (if pid-file? + (list #~(string-append "--pid-file=" #$pid-file)) + '()))) + (cons* #~(string-append "--host-key=" + #$(lsh-configuration-host-key config)) + #~(string-append "--password-helper=" #$lsh "/sbin/lsh-pam-checkpw") + #~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server") + "-p" (number->string (lsh-configuration-port-number config)) + (if (lsh-configuration-password-authentication? config) + "--password" "--no-password") + (if (lsh-configuration-public-key-authentication? config) + "--publickey" "--no-publickey") + (if (lsh-configuration-root-login? config) + "--root-login" "--no-root-login") + (if (lsh-configuration-x11-forwarding? config) + "--x11-forward" "--no-x11-forward") + (if (lsh-configuration-tcp/ip-forwarding? config) + "--tcpip-forward" "--no-tcpip-forward") + (if (null? interfaces) + '() + (list (string-append "--interfaces=" + (string-join interfaces ","))))))) + + (define requires + (if (and daemonic? (lsh-configuration-syslog-output? config)) + '(networking syslogd) + '(networking))) + + (list (dmd-service + (documentation "GNU lsh SSH server") + (provision '(ssh-daemon)) + (requirement requires) + (start #~(make-forkexec-constructor (list #$@lsh-command))) + (stop #~(make-kill-destructor))))) + +(define (lsh-pam-services config) + "Return a list of <pam-services> for lshd with CONFIG." + (list (unix-pam-service + "lshd" + #:allow-empty-passwords? + (lsh-configuration-allow-empty-passwords? config)))) + +(define lsh-service-type + (service-type (name 'lsh) + (extensions + (list (service-extension dmd-root-service-type + lsh-dmd-service) + (service-extension pam-root-service-type + lsh-pam-services) + (service-extension activation-service-type + lsh-activation))))) + (define* (lsh-service #:key (lsh lsh) (daemonic? #t) @@ -115,59 +218,20 @@ passwords, and @var{root-login?} specifies whether to accept log-ins as root. The other options should be self-descriptive." - (define lsh-command - (append - (cons #~(string-append #$lsh "/sbin/lshd") - (if daemonic? - (let ((syslog (if syslog-output? '() - (list "--no-syslog")))) - (cons "--daemonic" - (if pid-file? - (cons #~(string-append "--pid-file=" #$pid-file) - syslog) - (cons "--no-pid-file" syslog)))) - (if pid-file? - (list #~(string-append "--pid-file=" #$pid-file)) - '()))) - (cons* #~(string-append "--host-key=" #$host-key) - #~(string-append "--password-helper=" #$lsh "/sbin/lsh-pam-checkpw") - #~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server") - "-p" (number->string port-number) - (if password-authentication? "--password" "--no-password") - (if public-key-authentication? - "--publickey" "--no-publickey") - (if root-login? - "--root-login" "--no-root-login") - (if x11-forwarding? - "--x11-forward" "--no-x11-forward") - (if tcp/ip-forwarding? - "--tcpip-forward" "--no-tcpip-forward") - (if (null? interfaces) - '() - (list (string-append "--interfaces=" - (string-join interfaces ","))))))) - - (define requires - (if (and daemonic? syslog-output?) - '(networking syslogd) - '(networking))) - - (with-monad %store-monad - (return (service - (documentation "GNU lsh SSH server") - (provision '(ssh-daemon)) - (requirement requires) - (start #~(make-forkexec-constructor (list #$@lsh-command))) - (stop #~(make-kill-destructor)) - (pam-services - (list (unix-pam-service - "lshd" - #:allow-empty-passwords? allow-empty-passwords?))) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/spool/lsh") - #$(if initialize? - (activation lsh host-key) - #t))))))) + (service lsh-service-type + (lsh-configuration (lsh lsh) (daemonic? daemonic?) + (host-key host-key) (interfaces interfaces) + (port-number port-number) + (allow-empty-passwords? allow-empty-passwords?) + (root-login? root-login?) + (syslog-output? syslog-output?) + (pid-file? pid-file?) (pid-file pid-file) + (x11-forwarding? x11-forwarding?) + (tcp/ip-forwarding? tcp/ip-forwarding?) + (password-authentication? + password-authentication?) + (public-key-authentication? + public-key-authentication?) + (initialize? initialize?)))) ;;; ssh.scm ends here diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 2db5b76ce4..84bb30d8fd 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,13 +19,13 @@ (define-module (gnu services web) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu system shadow) #:use-module (gnu packages admin) #:use-module (gnu packages web) #:use-module (guix records) - #:use-module (guix monads) - #:use-module (guix store) #:use-module (guix gexp) + #:use-module (ice-9 match) #:export (nginx-service)) ;;; Commentary: @@ -33,6 +34,14 @@ ;;; ;;; Code: +(define-record-type* <nginx-configuration> + nginx-configuration make-nginx-configuration + nginx-configuration? + (nginx nginx-configuration-nginx) ;<package> + (log-directory nginx-configuration-log-directory) ;string + (run-directory nginx-configuration-run-directory) ;string + (file nginx-configuration-file)) ;string | file-like + (define (default-nginx-config log-directory run-directory) (plain-file "nginx.conf" (string-append @@ -46,6 +55,58 @@ "}\n" "events {}\n"))) +(define %nginx-accounts + (list (user-group (name "nginx") (system? #t)) + (user-account + (name "nginx") + (group "nginx") + (system? #t) + (comment "nginx server user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define nginx-activation + (match-lambda + (($ <nginx-configuration> nginx log-directory run-directory config-file) + #~(begin + (use-modules (guix build utils)) + + (format #t "creating nginx log directory '~a'~%" #$log-directory) + (mkdir-p #$log-directory) + (format #t "creating nginx run directory '~a'~%" #$run-directory) + (mkdir-p #$run-directory) + ;; Check configuration file syntax. + (system* (string-append #$nginx "/bin/nginx") + "-c" #$config-file "-t"))))) + +(define nginx-dmd-service + (match-lambda + (($ <nginx-configuration> nginx log-directory run-directory config-file) + (let* ((nginx-binary #~(string-append #$nginx "/sbin/nginx")) + (nginx-action + (lambda args + #~(lambda _ + (zero? + (system* #$nginx-binary "-c" #$config-file #$@args)))))) + + ;; TODO: Add 'reload' action. + (list (dmd-service + (provision '(nginx)) + (documentation "Run the nginx daemon.") + (requirement '(user-processes loopback)) + (start (nginx-action "-p" run-directory)) + (stop (nginx-action "-s" "stop")))))))) + +(define nginx-service-type + (service-type (name 'nginx) + (extensions + (list (service-extension dmd-root-service-type + nginx-dmd-service) + (service-extension activation-service-type + nginx-activation) + (service-extension account-service-type + (const %nginx-accounts)))))) + (define* (nginx-service #:key (nginx nginx) (log-directory "/var/log/nginx") (run-directory "/var/run/nginx") @@ -55,43 +116,9 @@ The nginx daemon loads its runtime configuration from CONFIG-FIGLE, stores log files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY." - (define nginx-binary - #~(string-append #$nginx "/sbin/nginx")) - - (define (nginx-action . args) - #~(lambda _ - (zero? - (system* #$nginx-binary "-c" #$config-file #$@args)))) - - (define activate - #~(begin - (use-modules (guix build utils)) - (format #t "creating nginx log directory '~a'~%" #$log-directory) - (mkdir-p #$log-directory) - (format #t "creating nginx run directory '~a'~%" #$run-directory) - (mkdir-p #$run-directory) - ;; Check configuration file syntax. - (system* #$nginx-binary "-c" #$config-file "-t"))) - - (define nologin #~(string-append #$shadow "/sbin/nologin")) - - ;; TODO: Add 'reload' action. - (mbegin %store-monad - (return - (service - (provision '(nginx)) - (documentation "Run the nginx daemon.") - (requirement '(user-processes loopback)) - (start (nginx-action "-p" run-directory)) - (stop (nginx-action "-s" "stop")) - (activate activate) - (user-groups (list (user-group - (name "nginx") - (system? #t)))) - (user-accounts (list (user-account - (name "nginx") - (group "nginx") - (system? #t) - (comment "nginx server user") - (home-directory "/var/empty") - (shell nologin)))))))) + (service nginx-service-type + (nginx-configuration + (nginx nginx) + (log-directory log-directory) + (run-directory run-directory) + (file config-file)))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 9ee88170e4..812cb3f725 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -20,6 +20,7 @@ (define-module (gnu services xorg) #:use-module (gnu artwork) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu system linux) ; 'pam-service' #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) @@ -31,7 +32,6 @@ #:use-module (gnu packages bash) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix records) #:use-module (srfi srfi-1) @@ -63,8 +63,8 @@ appropriate screen resolution; otherwise, it must be a list of resolutions---e.g., @code{((1024 768) (640 480))}. 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 -verbatim to the configuration file." +@code{mixed-text-file} argument list. It is used to pass extra text to be +added verbatim to the configuration file." (define (device-section driver) (string-append " Section \"Device\" @@ -87,7 +87,7 @@ Section \"Screen\" EndSubSection EndSection")) - (apply text-file* "xserver.conf" " + (apply mixed-text-file "xserver.conf" " Section \"Files\" FontPath \"" font-adobe75dpi "/share/fonts/X11/75dpi\" ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" @@ -128,7 +128,7 @@ EndSection (define* (xorg-start-command #:key (guile (canonical-package guile-2.0)) - configuration-file + (configuration-file (xorg-configuration-file)) (xorg-server xorg-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 @@ -136,27 +136,24 @@ file or a derivation that builds it; when omitted, the result of @code{xorg-configuration-file} is used. Usually the X server is started by a login manager." - (mlet %store-monad ((config (if configuration-file - (return configuration-file) - (xorg-configuration-file)))) - (define script - ;; Write a small wrapper around the X server. - #~(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") - (string-append #$xorg-server "/bin/X") ;argv[0] - "-logverbose" "-verbose" - "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") - "-config" #$config - "-nolisten" "tcp" "-terminate" - - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line))))) - - (gexp->script "start-xorg" script))) + (define exp + ;; Write a small wrapper around the X server. + #~(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") + (string-append #$xorg-server "/bin/X") ;argv[0] + "-logverbose" "-verbose" + "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") + "-config" #$configuration-file + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line))))) + + (program-file "start-xorg" exp)) (define* (xinitrc #:key (guile (canonical-package guile-2.0)) @@ -200,7 +197,7 @@ which should be passed to this script as the first argument. If not, the (exec-from-login-shell xsession-file session) ;; Otherwise, start the specified session. (exec-from-login-shell session))))) - (gexp->script "xinitrc" builder)) + (program-file "xinitrc" builder)) ;;; @@ -216,6 +213,95 @@ which should be passed to this script as the first argument. If not, the ;; contains the actual theme files. "0.x") +(define-record-type* <slim-configuration> + slim-configuration make-slim-configuration + slim-configuration? + (slim slim-configuration-slim + (default slim)) + (allow-empty-passwords? slim-configuration-allow-empty-passwords?) + (auto-login? slim-configuration-auto-login?) + (default-user slim-configuration-default-user) + (theme slim-configuration-theme) + (theme-name slim-configuration-theme-name) + (xauth slim-configuration-xauth + (default xauth)) + (dmd slim-configuration-dmd + (default dmd)) + (bash slim-configuration-bash + (default bash)) + (auto-login-session slim-configuration-auto-login-session) + (startx slim-configuration-startx)) + +(define (slim-pam-service config) + "Return a PAM service for @command{slim}." + (list (unix-pam-service + "slim" + #:allow-empty-passwords? + (slim-configuration-allow-empty-passwords? config)))) + +(define (slim-dmd-service config) + (define slim.cfg + (let ((xinitrc (xinitrc #:fallback-session + (slim-configuration-auto-login-session config))) + (slim (slim-configuration-slim config)) + (xauth (slim-configuration-xauth config)) + (startx (slim-configuration-startx config)) + (dmd (slim-configuration-dmd config)) + (theme-name (slim-configuration-theme-name config))) + (mixed-text-file "slim.cfg" " +default_path /run/current-system/profile/bin +default_xserver " startx " +xserver_arguments :0 vt7 +xauth_path " xauth "/bin/xauth +authfile /var/run/slim.auth + +# The login command. '%session' is replaced by the chosen session name, one +# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. +login_cmd exec " xinitrc " %session +sessiondir /run/current-system/profile/share/xsessions +session_msg session (F1 to change): + +halt_cmd " dmd "/sbin/halt +reboot_cmd " dmd "/sbin/reboot\n" +(if (slim-configuration-auto-login? config) + (string-append "auto_login yes\ndefault_user " + (slim-configuration-default-user config) "\n") + "") +(if theme-name + (string-append "current_theme " theme-name "\n") + "")))) + + (define theme + (slim-configuration-theme config)) + + (list (dmd-service + (documentation "Xorg display server") + (provision '(xorg-server)) + (requirement '(user-processes host-name udev)) + (start + #~(lambda () + ;; A stale lock file can prevent SLiM from starting, so remove it to + ;; be on the safe side. + (false-if-exception (delete-file "/var/run/slim.lock")) + + (fork+exec-command + (list (string-append #$slim "/bin/slim") "-nodaemon") + #:environment-variables + (list (string-append "SLIM_CFGFILE=" #$slim.cfg) + #$@(if theme + (list #~(string-append "SLIM_THEMESDIR=" #$theme)) + #~()))))) + (stop #~(make-kill-destructor)) + (respawn? #t)))) + +(define slim-service-type + (service-type (name 'slim) + (extensions + (list (service-extension dmd-root-service-type + slim-dmd-service) + (service-extension pam-root-service-type + slim-pam-service))))) + (define* (slim-service #:key (slim slim) (allow-empty-passwords? #t) auto-login? (default-user "") @@ -224,7 +310,7 @@ which should be passed to this script as the first argument. If not, the (xauth xauth) (dmd dmd) (bash bash) (auto-login-session #~(string-append #$windowmaker "/bin/wmaker")) - startx) + (startx (xorg-start-command))) "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 @code{xorg-start-command}. @@ -250,61 +336,14 @@ If @var{theme} is @code{#f}, the use the default log-in theme; otherwise @var{theme} must be a gexp denoting the name of a directory containing the theme to use. In that case, @var{theme-name} specifies the name of the theme." - - (define (slim.cfg) - (mlet %store-monad ((startx (if startx - (return startx) - (xorg-start-command))) - (xinitrc (xinitrc #:fallback-session - auto-login-session))) - (text-file* "slim.cfg" " -default_path /run/current-system/profile/bin -default_xserver " startx " -xserver_arguments :0 vt7 -xauth_path " xauth "/bin/xauth -authfile /var/run/slim.auth - -# The login command. '%session' is replaced by the chosen session name, one -# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. -login_cmd exec " xinitrc " %session -sessiondir /run/current-system/profile/share/xsessions -session_msg session (F1 to change): - -halt_cmd " dmd "/sbin/halt -reboot_cmd " dmd "/sbin/reboot -" -(if auto-login? - (string-append "auto_login yes\ndefault_user " default-user "\n") - "") -(if theme-name - (string-append "current_theme " theme-name "\n") - "")))) - - (mlet %store-monad ((slim.cfg (slim.cfg))) - (return - (service - (documentation "Xorg display server") - (provision '(xorg-server)) - (requirement '(user-processes host-name udev)) - (start - #~(lambda () - ;; A stale lock file can prevent SLiM from starting, so remove it - ;; to be on the safe side. - (false-if-exception (delete-file "/var/run/slim.lock")) - - (fork+exec-command - (list (string-append #$slim "/bin/slim") "-nodaemon") - #:environment-variables - (list (string-append "SLIM_CFGFILE=" #$slim.cfg) - #$@(if theme - (list #~(string-append "SLIM_THEMESDIR=" #$theme)) - #~()))))) - (stop #~(make-kill-destructor)) - (respawn? #t) - (pam-services - ;; Tell PAM about 'slim'. - (list (unix-pam-service - "slim" - #:allow-empty-passwords? allow-empty-passwords?))))))) + (service slim-service-type + (slim-configuration + (slim slim) + (allow-empty-passwords? allow-empty-passwords?) + (auto-login? auto-login?) (default-user default-user) + (theme theme) (theme-name theme-name) + (xauth xauth) (dmd dmd) (bash bash) + (auto-login-session auto-login-session) + (startx startx)))) ;;; xorg.scm ends here diff --git a/gnu/system.scm b/gnu/system.scm index cee5f37bcb..b32d26bc8e 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -87,8 +87,6 @@ operating-system-locale-directory operating-system-boot-script - file-union - local-host-aliases %setuid-programs %base-packages @@ -162,41 +160,6 @@ ;;; -;;; Derivation. -;;; - -(define* (file-union name files) - "Return a derivation that builds a directory containing all of FILES. Each -item in FILES must be a list where the first element is the file name to use -in the new directory, and the second element is a gexp denoting the target -file." - (define builder - #~(begin - (mkdir #$output) - (chdir #$output) - #$@(map (match-lambda - ((target source) - #~(symlink #$source #$target))) - files))) - - (gexp->derivation name builder)) - -(define (directory-union name things) - "Return a directory that is the union of THINGS." - (match things - ((one) - ;; Only one thing; return it. - (with-monad %store-monad (return one))) - (_ - (gexp->derivation name - #~(begin - (use-modules (guix build union)) - (union-build #$output '#$things)) - #:modules '((guix build union)) - #:local-build? #t)))) - - -;;; ;;; Services. ;;; @@ -244,19 +207,7 @@ as 'needed-for-boot'." (string->symbol (mapped-device-target md)))) (device-mappings fs)))) - (sequence %store-monad - (map (lambda (fs) - (match fs - (($ <file-system> device title target type flags opts - #f check? create?) - (file-system-service device target type - #:title title - #:requirements (requirements fs) - #:check? check? - #:create-mount-point? create? - #:options opts - #:flags flags)))) - file-systems))) + (map file-system-service file-systems)) (define (mapped-device-user device file-systems) "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f." @@ -287,51 +238,66 @@ from the initrd." devices))) (define (device-mapping-services os) - "Return the list of device-mapping services for OS as a monadic list." - (sequence %store-monad - (map (lambda (md) - (let* ((source (mapped-device-source md)) - (target (mapped-device-target md)) - (type (mapped-device-type md)) - (open (mapped-device-kind-open type)) - (close (mapped-device-kind-close type))) - (device-mapping-service target - (open source target) - (close source target)))) - (operating-system-user-mapped-devices os)))) + "Return the list of device-mapping services for OS as a list." + (map (lambda (md) + (let* ((source (mapped-device-source md)) + (target (mapped-device-target md)) + (type (mapped-device-type md)) + (open (mapped-device-kind-open type)) + (close (mapped-device-kind-close type))) + (device-mapping-service target + (open source target) + (close source target)))) + (operating-system-user-mapped-devices os))) (define (swap-services os) - "Return the list of swap services for OS as a monadic list." - (sequence %store-monad - (map swap-service (operating-system-swap-devices os)))) + "Return the list of swap services for OS." + (map swap-service (operating-system-swap-devices os))) -(define (essential-services os) +(define* (essential-services os #:key container?) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level -bookkeeping." +bookkeeping. CONTAINER? determines whether to return the list of services for +a container or that of a \"bare metal\" system." (define known-fs (map file-system-mount-point (operating-system-file-systems os))) - (mlet* %store-monad ((mappings (device-mapping-services os)) - (root-fs (root-file-system-service)) - (other-fs (other-file-system-services os)) - (unmount (user-unmount-service known-fs)) - (swaps (swap-services os)) - (procs (user-processes-service - (map (compose first service-provision) - other-fs))) - (host-name (host-name-service - (operating-system-host-name os)))) - (return (cons* host-name procs root-fs unmount - (append other-fs mappings swaps))))) - -(define (operating-system-services os) + (let* ((mappings (device-mapping-services os)) + (root-fs (root-file-system-service)) + (other-fs (other-file-system-services os)) + (unmount (user-unmount-service known-fs)) + (swaps (swap-services os)) + (procs (user-processes-service + (map service-parameters other-fs))) + (host-name (host-name-service (operating-system-host-name os)))) + (cons* %boot-service + + ;; %DMD-ROOT-SERVICE must come first so that the gexp that execs + ;; dmd comes last in the boot script (XXX). + %dmd-root-service %activation-service + + (pam-root-service (operating-system-pam-services os)) + (account-service (append (operating-system-accounts os) + (operating-system-groups os)) + (operating-system-skeletons os)) + (operating-system-etc-service os) + host-name procs root-fs unmount + (service setuid-program-service-type + (operating-system-setuid-programs os)) + (append other-fs mappings swaps + + ;; Add the firmware service, unless we are building for a + ;; container. + (if container? + '() + (list (service firmware-service-type + (operating-system-firmware os)))))))) + +(define* (operating-system-services os #:key container?) "Return all the services of OS, including \"internal\" services that do not explicitly appear in OS." - (mlet %store-monad - ((user (sequence %store-monad (operating-system-user-services os))) - (essential (essential-services os))) - (return (append essential user)))) + (append (operating-system-user-services os) + (essential-services os #:container? container?))) ;;; @@ -394,79 +360,71 @@ This is the GNU system. Welcome.\n") (define (emacs-site-file) "Return the Emacs 'site-start.el' file. That file contains the necessary settings for 'guix.el' to work out-of-the-box." - (gexp->file "site-start.el" - #~(progn - ;; Add the "normal" elisp directory to the search path; - ;; guix.el may be there. - (add-to-list - 'load-path - "/run/current-system/profile/share/emacs/site-lisp") + (scheme-file "site-start.el" + #~(progn + ;; Add the "normal" elisp directory to the search path; + ;; guix.el may be there. + (add-to-list + 'load-path + "/run/current-system/profile/share/emacs/site-lisp") - ;; Attempt to load guix.el. - (require 'guix-init nil t) + ;; Attempt to load guix.el. + (require 'guix-init nil t) - ;; Attempt to load geiser. - (require 'geiser-install nil t)))) + ;; Attempt to load geiser. + (require 'geiser-install nil t)))) (define (emacs-site-directory) "Return the Emacs site directory, aka. /etc/emacs." - (mlet %store-monad ((file (emacs-site-file))) - (gexp->derivation "emacs" - #~(begin - (mkdir #$output) - (chdir #$output) - (symlink #$file "site-start.el"))))) + (computed-file "emacs" + #~(begin + (mkdir #$output) + (chdir #$output) + (symlink #$(emacs-site-file) "site-start.el")))) (define (user-shells os) "Return the list of all the shells used by the accounts of OS. These may be gexps or strings." - (mlet %store-monad ((accounts (operating-system-accounts os))) - (return (map user-account-shell accounts)))) + (map user-account-shell (operating-system-accounts os))) (define (shells-file shells) - "Return a derivation that builds a shell list for use as /etc/shells based -on SHELLS. /etc/shells is used by xterm, polkit, and other programs." - (gexp->derivation "shells" - #~(begin - (use-modules (srfi srfi-1)) - - (define shells - (delete-duplicates (list #$@shells))) - - (call-with-output-file #$output - (lambda (port) - (display "\ + "Return a file-like object that builds a shell list for use as /etc/shells +based on SHELLS. /etc/shells is used by xterm, polkit, and other programs." + (computed-file "shells" + #~(begin + (use-modules (srfi srfi-1)) + + (define shells + (delete-duplicates (list #$@shells))) + + (call-with-output-file #$output + (lambda (port) + (display "\ /bin/sh /run/current-system/profile/bin/sh /run/current-system/profile/bin/bash\n" port) - (for-each (lambda (shell) - (display shell port) - (newline port)) - shells)))))) - -(define* (etc-directory #:key - (locale "C") (timezone "Europe/Paris") - (issue "Hello!\n") - (skeletons '()) - (pam-services '()) - (profile "/run/current-system/profile") - hosts-file nss (shells '()) - (sudoers-file (plain-file "sudoers" ""))) - "Return a derivation that builds the static part of the /etc directory." - (mlet* %store-monad - ((pam.d (pam-services->directory pam-services)) - (login.defs (text-file "login.defs" "# Empty for now.\n")) - (shells (shells-file shells)) - (emacs (emacs-site-directory)) - (issue (text-file "issue" issue)) - (nsswitch (text-file "nsswitch.conf" - (name-service-switch->string nss))) - - ;; Startup file for POSIX-compliant login shells, which set system-wide - ;; environment variables. - (profile (text-file* "profile" "\ -export LANG=\"" locale "\" -export TZ=\"" timezone "\" + (for-each (lambda (shell) + (display shell port) + (newline port)) + shells)))))) + +(define* (operating-system-etc-service os) + "Return a <service> that builds containing the static part of the /etc +directory." + (let ((login.defs (plain-file "login.defs" "# Empty for now.\n")) + + (shells (shells-file (user-shells os))) + (emacs (emacs-site-directory)) + (issue (plain-file "issue" (operating-system-issue os))) + (nsswitch (plain-file "nsswitch.conf" + (name-service-switch->string + (operating-system-name-service-switch os)))) + + ;; Startup file for POSIX-compliant login shells, which set system-wide + ;; environment variables. + (profile (mixed-text-file "profile" "\ +export LANG=\"" (operating-system-locale os) "\" +export TZ=\"" (operating-system-timezone os) "\" export TZDIR=\"" tzdata "/share/zoneinfo\" # Tell 'modprobe' & co. where to look for modules. @@ -523,7 +481,7 @@ then fi ")) - (bashrc (text-file "bashrc" "\ + (bashrc (plain-file "bashrc" "\ # Bash-specific initialization. # The 'bash-completion' package. @@ -533,25 +491,23 @@ then # completion loader that searches its own completion files as well # as those in ~/.guix-profile and /run/current-system/profile. source /run/current-system/profile/etc/profile.d/bash_completion.sh -fi\n")) - (skel (skeleton-directory skeletons))) - (file-union "etc" - `(("services" ,#~(string-append #$net-base "/etc/services")) - ("protocols" ,#~(string-append #$net-base "/etc/protocols")) - ("rpc" ,#~(string-append #$net-base "/etc/rpc")) - ("emacs" ,#~#$emacs) - ("pam.d" ,#~#$pam.d) - ("login.defs" ,#~#$login.defs) - ("issue" ,#~#$issue) - ("nsswitch.conf" ,#~#$nsswitch) - ("skel" ,#~#$skel) - ("shells" ,#~#$shells) - ("profile" ,#~#$profile) - ("bashrc" ,#~#$bashrc) - ("hosts" ,#~#$hosts-file) - ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" - #$timezone)) - ("sudoers" ,sudoers-file))))) +fi\n"))) + (etc-service + `(("services" ,#~(string-append #$net-base "/etc/services")) + ("protocols" ,#~(string-append #$net-base "/etc/protocols")) + ("rpc" ,#~(string-append #$net-base "/etc/rpc")) + ("emacs" ,#~#$emacs) + ("login.defs" ,#~#$login.defs) + ("issue" ,#~#$issue) + ("nsswitch.conf" ,#~#$nsswitch) + ("shells" ,#~#$shells) + ("profile" ,#~#$profile) + ("bashrc" ,#~#$bashrc) + ("hosts" ,#~#$(or (operating-system-hosts-file os) + (default-/etc/hosts (operating-system-host-name os)))) + ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" + #$(operating-system-timezone os))) + ("sudoers" ,(operating-system-sudoers-file os)))))) (define (operating-system-profile os) "Return a derivation that builds the system profile of OS." @@ -568,18 +524,14 @@ fi\n")) (home-directory "/root"))) (define (operating-system-accounts os) - "Return the user accounts for OS, including an obligatory 'root' account." - (define users - ;; Make sure there's a root account. - (if (find (lambda (user) - (and=> (user-account-uid user) zero?)) - (operating-system-users os)) - (operating-system-users os) - (cons %root-account (operating-system-users os)))) - - (mlet %store-monad ((services (operating-system-services os))) - (return (append users - (append-map service-user-accounts services))))) + "Return the user accounts for OS, including an obligatory 'root' account, +and excluding accounts requested by services." + ;; Make sure there's a root account. + (if (find (lambda (user) + (and=> (user-account-uid user) zero?)) + (operating-system-users os)) + (operating-system-users os) + (cons %root-account (operating-system-users os)))) (define (maybe-string->file file-name thing) "If THING is a string, return a <plain-file> with THING as its content. @@ -614,31 +566,9 @@ use 'plain-file' instead~%") (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." - (mlet* %store-monad - ((services (operating-system-services os)) - (pam-services -> - ;; Services known to PAM. - (append (operating-system-pam-services os) - (append-map service-pam-services services))) - (profile-drv (operating-system-profile os)) - (skeletons (operating-system-skeletons os)) - (/etc/hosts (maybe-file->monadic - "hosts" - (or (operating-system-hosts-file os) - (default-/etc/hosts (operating-system-host-name os))))) - (shells (user-shells os))) - (etc-directory #:pam-services pam-services - #:skeletons skeletons - #:issue (operating-system-issue os) - #:locale (operating-system-locale os) - #:nss (operating-system-name-service-switch os) - #:timezone (operating-system-timezone os) - #:hosts-file /etc/hosts - #:shells shells - #:sudoers-file (maybe-string->file - "sudoers" - (operating-system-sudoers-file os)) - #:profile profile-drv))) + (etc-directory + (fold-services (operating-system-services os) + #:target-type etc-service-type))) (define %setuid-programs ;; Default set of setuid-root programs. @@ -659,177 +589,23 @@ use 'plain-file' instead~%") root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n")) -(define (user-group->gexp group) - "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for -'active-groups'." - #~(list #$(user-group-name group) - #$(user-group-password group) - #$(user-group-id group) - #$(user-group-system? group))) - -(define (user-account->gexp account) - "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for -'activate-users'." - #~`(#$(user-account-name account) - #$(user-account-uid account) - #$(user-account-group account) - #$(user-account-supplementary-groups account) - #$(user-account-comment account) - #$(user-account-home-directory account) - ,#$(user-account-shell account) ; this one is a gexp - #$(user-account-password account) - #$(user-account-system? account))) - -(define (modprobe-wrapper) - "Return a wrapper for the 'modprobe' command that knows where modules live. - -This wrapper is typically invoked by the Linux kernel ('call_modprobe', in -kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment -variable is not set---hence the need for this wrapper." - (let ((modprobe "/run/current-system/profile/bin/modprobe")) - (gexp->script "modprobe" - #~(begin - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - (apply execl #$modprobe - (cons #$modprobe (cdr (command-line)))))))) - (define* (operating-system-activation-script os #:key container?) "Return the activation script for OS---i.e., the code that \"activates\" the stateful part of OS, including user accounts and groups, special directories, etc." - (define %modules - '((gnu build activation) - (gnu build linux-boot) - (gnu build linux-modules) - (gnu build file-systems) - (guix build utils) - (guix build syscalls) - (guix elf))) - - (define (service-activations services) - ;; Return the activation scripts for SERVICES. - (let ((gexps (filter-map service-activate services))) - (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>) - gexps)))) - - (mlet* %store-monad ((services (operating-system-services os)) - (actions (service-activations services)) - (etc (operating-system-etc-directory os)) - (modules (imported-modules %modules)) - (compiled (compiled-modules %modules)) - (modprobe (modprobe-wrapper)) - (firmware (directory-union - "firmware" (operating-system-firmware os))) - (accounts (operating-system-accounts os))) - (define setuid-progs - (operating-system-setuid-programs os)) - - (define user-specs - (map user-account->gexp accounts)) - - (define groups - (append (operating-system-groups os) - (append-map service-user-groups services))) - - (define group-specs - (map user-group->gexp groups)) - - (assert-valid-users/groups accounts groups) - - (gexp->file "activate" - #~(begin - (eval-when (expand load eval) - ;; Make sure 'use-modules' below succeeds. - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - - (use-modules (gnu build activation)) - - ;; Make sure /bin/sh is valid and current. - (activate-/bin/sh - (string-append #$(canonical-package bash) - "/bin/sh")) - - ;; Populate /etc. - (activate-etc #$etc) - - ;; Add users and user groups. - (setenv "PATH" - (string-append #$(@ (gnu packages admin) shadow) - "/sbin")) - (activate-users+groups (list #$@user-specs) - (list #$@group-specs)) - - ;; Activate setuid programs. - (activate-setuid-programs (list #$@setuid-progs)) - - ;; Tell the kernel to use our 'modprobe' command. - (activate-modprobe #$modprobe) - - ;; Tell the kernel where firmware is, unless we are - ;; activating a container. - #$@(if container? - #~() - ;; Tell the kernel where firmware is. - #~((activate-firmware - (string-append #$firmware "/lib/firmware")) - ;; Let users debug their own processes! - (activate-ptrace-attach))) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions) - - ;; Set up /run/current-system. - (activate-current-system))))) + (let* ((services (operating-system-services os #:container? container?)) + (activation (fold-services services + #:target-type activation-service-type))) + (activation-service->script activation))) (define* (operating-system-boot-script os #:key container?) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root. When CONTAINER? is true, skip all hardware-related operations as necessary when booting a Linux container." - (mlet* %store-monad ((services (operating-system-services os)) - (activate (operating-system-activation-script - os #:container? container?)) - (dmd-conf (dmd-configuration-file services))) - (gexp->file "boot" - #~(begin - (use-modules (guix build utils)) - - ;; Clean out /tmp and /var/run. - ;; - ;; XXX This needs to happen before service activations, so - ;; it has to be here, but this also implicitly assumes - ;; that /tmp and /var/run are on the root partition. - (false-if-exception (delete-file-recursively "/tmp")) - (false-if-exception (delete-file-recursively "/var/run")) - (false-if-exception (mkdir "/tmp")) - (false-if-exception (chmod "/tmp" #o1777)) - (false-if-exception (mkdir "/var/run")) - (false-if-exception (chmod "/var/run" #o755)) - - ;; Activate the system. - ;; TODO: Use 'load-compiled'. - (primitive-load #$activate) - - ;; Keep track of the booted system. - (false-if-exception (delete-file "/run/booted-system")) - (symlink (readlink "/run/current-system") - "/run/booted-system") - - ;; Close any remaining open file descriptors to be on the - ;; safe side. This must be the very last thing we do, - ;; because Guile has internal FDs such as 'sleep_pipe' - ;; that need to be alive. - (let loop ((fd 3)) - (when (< fd 1024) - (false-if-exception (close-fdes fd)) - (loop (+ 1 fd)))) - - ;; Start dmd. - (execl (string-append #$dmd "/bin/dmd") - "dmd" "--config" #$dmd-conf))))) + (let* ((services (operating-system-services os #:container? container?)) + (boot (fold-services services))) + ;; BOOT is the script as a monadic value. + (service-parameters boot))) (define (operating-system-root-file-system os) "Return the root file system of OS." @@ -916,19 +692,20 @@ this file is the reconstruction of GRUB menu entries for old configurations." "Return a derivation that builds OS." (mlet* %store-monad ((profile (operating-system-profile os)) - (etc (operating-system-etc-directory os)) + (etc -> (operating-system-etc-directory os)) (boot (operating-system-boot-script os)) (kernel -> (operating-system-kernel os)) (initrd (operating-system-initrd-file os)) (locale (operating-system-locale-directory os)) (params (operating-system-parameters-file os))) - (file-union "system" - `(("boot" ,#~#$boot) - ("kernel" ,#~#$kernel) - ("parameters" ,#~#$params) - ("initrd" ,initrd) - ("profile" ,#~#$profile) - ("locale" ,#~#$locale) ;used by libc - ("etc" ,#~#$etc))))) + (lower-object + (file-union "system" + `(("boot" ,#~#$boot) + ("kernel" ,#~#$kernel) + ("parameters" ,#~#$params) + ("initrd" ,initrd) + ("profile" ,#~#$profile) + ("locale" ,#~#$locale) ;used by libc + ("etc" ,#~#$etc)))))) ;;; system.scm ends here diff --git a/gnu/system/install.scm b/gnu/system/install.scm index c161526d77..a91c5c3533 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -24,6 +24,7 @@ #:use-module (guix monads) #:use-module ((guix store) #:select (%store-prefix)) #:use-module (guix profiles) + #:use-module (gnu services dmd) #:use-module (gnu packages admin) #:use-module (gnu packages bash) #:use-module (gnu packages linux) @@ -102,7 +103,7 @@ under /root/.guix-profile where GUIX is installed." (define (log-to-info) "Return a script that spawns the Info reader on the right section of the manual." - (gexp->script "log-to-info" + (program-file "log-to-info" #~(begin ;; 'gunzip' is needed to decompress the doc. (setenv "PATH" (string-append #$gzip "/bin")) @@ -159,70 +160,74 @@ current store is on a RAM disk." (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE) (rmdir "/.rw-store")))))) +(define cow-store-service-type + (dmd-service-type + (lambda _ + (dmd-service + (requirement '(root-file-system user-processes)) + (provision '(cow-store)) + (documentation + "Make the store copy-on-write, with writes going to \ +the given target.") + + ;; This is meant to be explicitly started by the user. + (auto-start? #f) + + (start #~(case-lambda + ((target) + #$(make-cow-store #~target) + target) + (else + ;; Do nothing, and mark the service as stopped. + #f))) + (stop #~(lambda (target) + ;; Delete the temporary directory, but leave everything + ;; mounted as there may still be processes using it since + ;; 'user-processes' doesn't depend on us. The 'user-unmount' + ;; service will unmount TARGET eventually. + (delete-file-recursively + (string-append target #$%backing-directory)))))))) + (define (cow-store-service) "Return a service that makes the store copy-on-write, such that writes go to the user's target storage device rather than on the RAM disk." ;; See <http://bugs.gnu.org/18061> for the initial report. - (with-monad %store-monad - (return (service - (requirement '(root-file-system user-processes)) - (provision '(cow-store)) - (documentation - "Make the store copy-on-write, with writes going to \ -the given target.") + (service cow-store-service-type 'mooooh!)) + + +(define (/etc/configuration-files _) + "Return a list of tuples representing configuration templates to add to +/etc." + (define (file f) + (local-file (search-path %load-path + (string-append "gnu/system/examples/" f)))) + + (define directory + (computed-file "configuration-templates" + #~(begin + (mkdir #$output) + (for-each (lambda (file target) + (copy-file file + (string-append #$output "/" + target))) + '(#$(file "bare-bones.tmpl") + #$(file "desktop.tmpl")) + '("bare-bones.scm" + "desktop.scm")) + #t) + #:modules '((guix build utils)))) + + `(("configuration" ,directory))) + +(define configuration-template-service-type + (service-type (name 'configuration-template) + (extensions + (list (service-extension etc-service-type + /etc/configuration-files))))) + +(define %configuration-template-service + (service configuration-template-service-type #t)) - ;; This is meant to be explicitly started by the user. - (auto-start? #f) - - (start #~(case-lambda - ((target) - #$(make-cow-store #~target) - target) - (else - ;; Do nothing, and mark the service as stopped. - #f))) - (stop #~(lambda (target) - ;; Delete the temporary directory, but leave everything - ;; mounted as there may still be processes using it - ;; since 'user-processes' doesn't depend on us. The - ;; 'user-unmount' service will unmount TARGET - ;; eventually. - (delete-file-recursively - (string-append target #$%backing-directory)))))))) - -(define (configuration-template-service) - "Return a dummy service whose purpose is to install an operating system -configuration template file in the installation system." - - (define search - (cut search-path %load-path <>)) - (define templates - (map (match-lambda - ((file '-> target) - (list (local-file (search file)) - (string-append "/etc/configuration/" target)))) - '(("gnu/system/examples/bare-bones.tmpl" -> "bare-bones.scm") - ("gnu/system/examples/desktop.tmpl" -> "desktop.scm")))) - - (with-monad %store-monad - (return (service - (requirement '(root-file-system)) - (provision '(os-config-template)) - (documentation - "This dummy service installs an OS configuration template.") - (start #~(const #t)) - (stop #~(const #f)) - (activate - #~(begin - (use-modules (ice-9 match) - (guix build utils)) - - (mkdir-p "/etc/configuration") - (for-each (match-lambda - ((file target) - (unless (file-exists? target) - (copy-file file target)))) - '#$templates))))))) (define %nscd-minimal-caches ;; Minimal in-memory caching policy for nscd. @@ -234,7 +239,7 @@ configuration template file in the installation system." (define (installation-services) "Return the list services for the installation image." - (let ((motd (text-file "motd" " + (let ((motd (plain-file "motd" " Welcome to the installation of the Guix System Distribution! There is NO WARRANTY, to the extent permitted by law. In particular, you may @@ -244,25 +249,27 @@ it is alpha software, so it may BREAK IN UNEXPECTED WAYS. You have been warned. Thanks for being so brave. "))) (define (normal-tty tty) - (mingetty-service tty - #:motd motd - #:auto-login "root" - #:login-pause? #t)) + (mingetty-service (mingetty-configuration (tty tty) + (motd motd) + (auto-login "root") + (login-pause? #t)))) - (list (mingetty-service "tty1" - #:motd motd - #:auto-login "root") + (list (mingetty-service (mingetty-configuration + (tty "tty1") + (motd motd) + (auto-login "root"))) ;; Documentation. The manual is in UTF-8, but ;; 'console-font-service' sets up Unicode support and loads a font ;; with all the useful glyphs like em dash and quotation marks. - (mingetty-service "tty2" - #:motd motd - #:auto-login "guest" - #:login-program (log-to-info)) + (mingetty-service (mingetty-configuration + (tty "tty2") + (motd motd) + (auto-login "guest") + (login-program (log-to-info)))) ;; Documentation add-on. - (configuration-template-service) + %configuration-template-service ;; A bunch of 'root' ttys. (normal-tty "tty3") @@ -276,7 +283,7 @@ You have been warned. Thanks for being so brave. ;; The build daemon. Register the hydra.gnu.org key as trusted. ;; This allows the installation process to use substitutes by ;; default. - (guix-service #:authorize-hydra-key? #t) + (guix-service (guix-configuration (authorize-key? #t))) ;; Start udev so that useful device nodes are available. ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 7461a4a61f..cd14bc97be 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,11 +17,10 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu system linux) - #:use-module (guix store) #:use-module (guix records) #:use-module (guix derivations) - #:use-module (guix monads) #:use-module (guix gexp) + #:use-module (gnu services) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -30,7 +29,10 @@ pam-entry pam-services->directory unix-pam-service - base-pam-services)) + base-pam-services + + pam-root-service-type + pam-root-service)) ;;; Commentary: ;;; @@ -86,18 +88,13 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." (map (cut entry->gexp "session" <>) session)) #t)))) - (gexp->derivation name builder)))) + (computed-file name builder)))) (define (pam-services->directory services) "Return the derivation to build the configuration directory to be used as /etc/pam.d for SERVICES." - (mlet %store-monad - ((names -> (map pam-service-name services)) - (files (sequence %store-monad - (map pam-service->configuration - ;; XXX: Eventually, SERVICES may be a list of - ;; monadic values instead of plain values. - services)))) + (let ((names (map pam-service-name services)) + (files (map pam-service->configuration services))) (define builder #~(begin (use-modules (ice-9 match) @@ -105,8 +102,8 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." (mkdir #$output) (for-each (match-lambda - ((name file) - (symlink file (string-append #$output "/" name)))) + ((name file) + (symlink file (string-append #$output "/" name)))) ;; Since <pam-service> objects cannot be compared with ;; 'equal?' since they contain gexps, which contain @@ -114,7 +111,7 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." ;; instead. See <http://bugs.gnu.org/20037>. (delete-duplicates '#$(zip names files))))) - (gexp->derivation "pam.d" builder))) + (computed-file "pam.d" builder))) (define %pam-other-services ;; The "other" PAM configuration, which denies everything (see @@ -136,7 +133,7 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." (lambda* (name #:key allow-empty-passwords? motd) "Return a standard Unix-style PAM service for NAME. When ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords. When MOTD is true, it -should be the name of a file used as the message-of-the-day." +should be a file-like object used as the message-of-the-day." ;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>. (let ((name* name)) (pam-service @@ -195,4 +192,24 @@ authenticate to run COMMAND." '("useradd" "userdel" "usermod" "groupadd" "groupdel" "groupmod")))) + +;;; +;;; PAM root service. +;;; + +(define (/etc-entry services) + `(("pam.d" ,(pam-services->directory services)))) + +(define pam-root-service-type + (service-type (name 'pam) + (extensions (list (service-extension etc-service-type + /etc-entry))) + (compose concatenate) + (extend append))) + +(define (pam-root-service base) + "The \"root\" PAM service, which collects <pam-service> instance and turns +them into a /etc/pam.d directory, including the <pam-service> listed in BASE." + (service pam-root-service-type base)) + ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index f033109614..3f49c1fc9f 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -20,15 +20,16 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (guix sets) #:use-module (guix ui) + #:use-module (gnu services) #:use-module ((gnu system file-systems) #:select (%tty-gid)) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) #:use-module (gnu packages guile-wm) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -55,7 +56,9 @@ skeleton-directory %base-groups %base-user-accounts - assert-valid-users/groups)) + + account-service-type + account-service)) ;;; Commentary: ;;; @@ -88,31 +91,32 @@ (system? user-group-system? ; Boolean (default #f))) + (define %base-groups ;; Default set of groups. (let-syntax ((system-group (syntax-rules () ((_ args ...) (user-group (system? #t) args ...))))) (list (system-group (name "root") (id 0)) - (system-group (name "wheel")) ; root-like users - (system-group (name "users")) ; normal users - (system-group (name "nogroup")) ; for daemons etc. + (system-group (name "wheel")) ; root-like users + (system-group (name "users")) ; normal users + (system-group (name "nogroup")) ; for daemons etc. ;; The following groups are conventionally used by things like udev to ;; control access to hardware devices. (system-group (name "tty") (id %tty-gid)) (system-group (name "dialout")) (system-group (name "kmem")) - (system-group (name "input")) ; input devices, from udev + (system-group (name "input")) ; input devices, from udev (system-group (name "video")) (system-group (name "audio")) - (system-group (name "netdev")) ; used in avahi-dbus.conf + (system-group (name "netdev")) ; used in avahi-dbus.conf (system-group (name "lp")) (system-group (name "disk")) (system-group (name "floppy")) (system-group (name "cdrom")) (system-group (name "tape")) - (system-group (name "kvm"))))) ; for /dev/kvm + (system-group (name "kvm"))))) ; for /dev/kvm (define %base-user-accounts ;; List of standard user accounts. Note that "root" is a special case, so @@ -133,10 +137,10 @@ (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) #$output))) - (mlet %store-monad ((profile (text-file "bash_profile" "\ + (let ((profile (plain-file "bash_profile" "\ # Honor per-interactive-shell startup file if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n")) - (bashrc (text-file "bashrc" "\ + (bashrc (plain-file "bashrc" "\ # Bash initialization for interactive non-login shells and # for remote shells (info \"(bash) Bash Startup Files\"). @@ -162,42 +166,41 @@ else fi alias ls='ls -p --color' alias ll='ls -l'\n")) - (zlogin (text-file "zlogin" "\ + (zlogin (plain-file "zlogin" "\ # Honor system-wide environment variables source /etc/profile\n")) - (guile-wm (gexp->derivation "guile-wm" copy-guile-wm - #:modules - '((guix build utils)))) - (xdefaults (text-file "Xdefaults" "\ + (guile-wm (computed-file "guile-wm" copy-guile-wm + #:modules '((guix build utils)))) + (xdefaults (plain-file "Xdefaults" "\ XTerm*utf8: always XTerm*metaSendsEscape: true\n")) - (gdbinit (text-file "gdbinit" "\ + (gdbinit (plain-file "gdbinit" "\ # Tell GDB where to look for separate debugging files. set debug-file-directory ~/.guix-profile/lib/debug\n"))) - (return `((".bash_profile" ,profile) - (".bashrc" ,bashrc) - (".zlogin" ,zlogin) - (".Xdefaults" ,xdefaults) - (".guile-wm" ,guile-wm) - (".gdbinit" ,gdbinit))))) + `((".bash_profile" ,profile) + (".bashrc" ,bashrc) + (".zlogin" ,zlogin) + (".Xdefaults" ,xdefaults) + (".guile-wm" ,guile-wm) + (".gdbinit" ,gdbinit)))) (define (skeleton-directory skeletons) - "Return a directory containing SKELETONS, a list of name/derivation pairs." - (gexp->derivation "skel" - #~(begin - (use-modules (ice-9 match)) - - (mkdir #$output) - (chdir #$output) - - ;; Note: copy the skeletons instead of symlinking - ;; them like 'file-union' does, because 'useradd' - ;; would just copy the symlinks as is. - (for-each (match-lambda - ((target source) - (copy-file source target))) - '#$skeletons) - #t))) + "Return a directory containing SKELETONS, a list of name/derivation tuples." + (computed-file "skel" + #~(begin + (use-modules (ice-9 match)) + + (mkdir #$output) + (chdir #$output) + + ;; Note: copy the skeletons instead of symlinking + ;; them like 'file-union' does, because 'useradd' + ;; would just copy the symlinks as is. + (for-each (match-lambda + ((target source) + (copy-file source target))) + '#$skeletons) + #t))) (define (assert-valid-users/groups users groups) "Raise an error if USERS refer to groups not listed in GROUPS." @@ -226,4 +229,81 @@ of user '~a' is undeclared") (user-account-supplementary-groups user))) users))) + +;;; +;;; Service. +;;; + +(define (user-group->gexp group) + "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for +'active-groups'." + #~(list #$(user-group-name group) + #$(user-group-password group) + #$(user-group-id group) + #$(user-group-system? group))) + +(define (user-account->gexp account) + "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for +'activate-users'." + #~`(#$(user-account-name account) + #$(user-account-uid account) + #$(user-account-group account) + #$(user-account-supplementary-groups account) + #$(user-account-comment account) + #$(user-account-home-directory account) + ,#$(user-account-shell account) ; this one is a gexp + #$(user-account-password account) + #$(user-account-system? account))) + +(define (account-activation accounts+groups) + "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and +<user-group> objects. Raise an error if a user account refers to a undefined +group." + (define accounts + (filter user-account? accounts+groups)) + + (define user-specs + (map user-account->gexp accounts)) + + (define groups + (filter user-group? accounts+groups)) + + (define group-specs + (map user-group->gexp groups)) + + (assert-valid-users/groups accounts groups) + + ;; Add users and user groups. + #~(begin + (setenv "PATH" + (string-append #$(@ (gnu packages admin) shadow) "/sbin")) + (activate-users+groups (list #$@user-specs) + (list #$@group-specs)))) + +(define (etc-skel arguments) + "Filter out among ARGUMENTS things corresponding to skeletons, and return +the /etc/skel directory for those." + (let ((skels (filter pair? arguments))) + `(("skel" ,(skeleton-directory skels))))) + +(define account-service-type + (service-type (name 'account) + + ;; Concatenate <user-account>, <user-group>, and skeleton + ;; lists. + (compose concatenate) + (extend append) + + (extensions + (list (service-extension activation-service-type + account-activation) + (service-extension etc-service-type + etc-skel))))) + +(define (account-service accounts+groups skeletons) + "Return a <service> that takes care of user accounts and user groups, with +ACCOUNTS+GROUPS as its initial list of accounts and groups." + (service account-service-type + (append skeletons accounts+groups))) + ;;; shadow.scm ends here diff --git a/guix/gexp.scm b/guix/gexp.scm index de49fef088..27bccc6206 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -43,10 +43,30 @@ plain-file-name plain-file-content + computed-file + computed-file? + computed-file-name + computed-file-gexp + computed-file-modules + computed-file-options + + program-file + program-file? + program-file-name + program-file-gexp + program-file-modules + program-file-guile + + scheme-file + scheme-file? + scheme-file-name + scheme-file-gexp + gexp->derivation gexp->file gexp->script text-file* + mixed-text-file imported-files imported-modules compiled-modules @@ -214,6 +234,77 @@ This is the declarative counterpart of 'text-file'." (($ <plain-file> name content references) (text-file name content references)))) +(define-record-type <computed-file> + (%computed-file name gexp modules options) + computed-file? + (name computed-file-name) ;string + (gexp computed-file-gexp) ;gexp + (modules computed-file-modules) ;list of module names + (options computed-file-options)) ;list of arguments + +(define* (computed-file name gexp + #:key (modules '()) (options '(#:local-build? #t))) + "Return an object representing the store item NAME, a file or directory +computed by GEXP. MODULES specifies the set of modules visible in the +execution context of GEXP. OPTIONS is a list of additional arguments to pass +to 'gexp->derivation'. + +This is the declarative counterpart of 'gexp->derivation'." + (%computed-file name gexp modules options)) + +(define-gexp-compiler (computed-file-compiler (file computed-file?) + system target) + ;; Compile FILE by returning a derivation whose build expression is its + ;; gexp. + (match file + (($ <computed-file> name gexp modules options) + (apply gexp->derivation name gexp #:modules modules options)))) + +(define-record-type <program-file> + (%program-file name gexp modules guile) + program-file? + (name program-file-name) ;string + (gexp program-file-gexp) ;gexp + (modules program-file-modules) ;list of module names + (guile program-file-guile)) ;package + +(define* (program-file name gexp + #:key (modules '()) (guile #f)) + "Return an object representing the executable store item NAME that runs +GEXP. GUILE is the Guile package used to execute that script, and MODULES is +the list of modules visible to that script. + +This is the declarative counterpart of 'gexp->script'." + (%program-file name gexp modules guile)) + +(define-gexp-compiler (program-file-compiler (file program-file?) + system target) + ;; Compile FILE by returning a derivation that builds the script. + (match file + (($ <program-file> name gexp modules guile) + (gexp->script name gexp + #:modules modules + #:guile (or guile (default-guile)))))) + +(define-record-type <scheme-file> + (%scheme-file name gexp) + scheme-file? + (name scheme-file-name) ;string + (gexp scheme-file-gexp)) ;gexp + +(define* (scheme-file name gexp) + "Return an object representing the Scheme file NAME that contains GEXP. + +This is the declarative counterpart of 'gexp->file'." + (%scheme-file name gexp)) + +(define-gexp-compiler (scheme-file-compiler (file scheme-file?) + system target) + ;; Compile FILE by returning a derivation that builds the file. + (match file + (($ <scheme-file> name gexp) + (gexp->file name gexp)))) + ;;; ;;; Inputs & outputs. @@ -903,6 +994,21 @@ resulting store file holds references to all these." (gexp->derivation name builder)) +(define* (mixed-text-file name #:rest text) + "Return an object representing store file NAME containing TEXT. TEXT is a +sequence of strings and file-like objects, as in: + + (mixed-text-file \"profile\" + \"export PATH=\" coreutils \"/bin:\" grep \"/bin\") + +This is the declarative counterpart of 'text-file*'." + (define build + (gexp (call-with-output-file (ungexp output "out") + (lambda (port) + (display (string-append (ungexp-splicing text)) port))))) + + (computed-file name build)) + ;;; ;;; Syntactic sugar. diff --git a/guix/scripts.scm b/guix/scripts.scm index e34d38904c..d84375f570 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -31,7 +31,8 @@ #:export (args-fold* parse-command-line maybe-build - build-package)) + build-package + build-package-source)) ;;; Commentary: ;;; @@ -115,4 +116,21 @@ Show what and how will/would be built." #:dry-run? dry-run?) (return (show-derivation-outputs derivation)))))) +(define* (build-package-source package + #:key dry-run? (use-substitutes? #t) + #:allow-other-keys + #:rest build-options) + "Build PACKAGE source using BUILD-OPTIONS." + (mbegin %store-monad + (apply set-build-options* + #:use-substitutes? use-substitutes? + (strip-keyword-arguments '(#:dry-run?) build-options)) + (mlet %store-monad ((derivation (origin->derivation + (package-source package)))) + (mbegin %store-monad + (maybe-build (list derivation) + #:use-substitutes? use-substitutes? + #:dry-run? dry-run?) + (return (show-derivation-outputs derivation)))))) + ;;; scripts.scm ends here diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 7aa52e8a8a..2408420e18 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -57,6 +57,9 @@ OUTPUT) tuples." (define %precious-variables '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER")) +(define %default-shell + (or (getenv "SHELL") "/bin/sh")) + (define (purify-environment) "Unset almost all environment variables. A small number of variables such as 'HOME' and 'USER' are left untouched." @@ -103,9 +106,9 @@ existing environment variables with additional search paths." ,@(package-transitive-propagated-inputs package))) (define (show-help) - (display (_ "Usage: guix environment [OPTION]... PACKAGE... -Build an environment that includes the dependencies of PACKAGE and execute a -shell command in that environment.\n")) + (display (_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] +Build an environment that includes the dependencies of PACKAGE and execute +COMMAND or an interactive shell in that environment.\n")) (display (_ " -e, --expression=EXPR create environment for the package that EXPR evaluates to")) @@ -113,8 +116,6 @@ shell command in that environment.\n")) -l, --load=FILE create environment for the package that the code within FILE evaluates to")) (display (_ " - -E, --exec=COMMAND execute COMMAND in new environment")) - (display (_ " --ad-hoc include all specified packages in the environment instead of only their inputs")) (display (_ " @@ -135,7 +136,7 @@ shell command in that environment.\n")) (define %default-options ;; Default to opening a new shell. - `((exec . ,(or (getenv "SHELL") "/bin/sh")) + `((exec . (,%default-shell)) (system . ,(%current-system)) (substitutes? . #t) (max-silent-time . 3600) @@ -153,9 +154,9 @@ shell command in that environment.\n")) (option '("pure") #f #f (lambda (opt name arg result) (alist-cons 'pure #t result))) - (option '(#\E "exec") #t #f + (option '(#\E "exec") #t #f ; deprecated (lambda (opt name arg result) - (alist-cons 'exec arg result))) + (alist-cons 'exec (list %default-shell "-c" arg) result))) (option '("search-paths") #f #f (lambda (opt name arg result) (alist-cons 'search-paths #t result))) @@ -230,14 +231,24 @@ OUTPUT) tuples, using the build options in OPTS." (built-derivations derivations) (return derivations)))))))) -;; Entry point. -(define (guix-environment . args) +(define (parse-args args) + "Parse the list of command line arguments ARGS." (define (handle-argument arg result) (alist-cons 'package arg result)) + ;; The '--' token is used to separate the command to run from the rest of + ;; the operands. + (let-values (((args command) (split args "--"))) + (let ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument))) + (if (null? command) + opts + (alist-cons 'exec command opts))))) + +;; Entry point. +(define (guix-environment . args) (with-error-handling - (let* ((opts (parse-command-line args %options (list %default-options) - #:argument-handler handle-argument)) + (let* ((opts (parse-args args)) (pure? (assoc-ref opts 'pure)) (ad-hoc? (assoc-ref opts 'ad-hoc?)) (command (assoc-ref opts 'exec)) @@ -282,4 +293,7 @@ OUTPUT) tuples, using the build options in OPTS." (return #t)) (else (create-environment inputs paths pure?) - (return (exit (status:exit-val (system command))))))))))))) + (return + (exit + (status:exit-val + (apply system* command))))))))))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 3b4ff722e9..b1707ade44 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -62,6 +62,7 @@ check-source-file-name check-license check-formatting + run-checkers %checkers lint-checker @@ -709,8 +710,8 @@ or a list thereof") (description "Look for formatting issues in the source") (check check-formatting)))) -(define (run-checkers package checkers) - ;; Run the given CHECKERS on PACKAGE. +(define* (run-checkers package #:optional (checkers %checkers)) + "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port))) (name (package-full-name package))) (for-each (lambda (checker) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5e2d226dfe..71b92dacc7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -300,7 +300,7 @@ it atomically, and then run OS's activation script." (system-disk-image os #:disk-image-size image-size)))) (define* (perform-action action os - #:key grub? dry-run? + #:key grub? dry-run? derivations-only? use-substitutes? device target image-size full-boot? (mappings '())) @@ -308,7 +308,13 @@ it atomically, and then run OS's activation script." the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE is the size of the image to be built, for the 'vm-image' and 'disk-image' actions. FULL-BOOT? is used for the 'vm' action; it determines whether to -boot directly to the kernel or to the bootloader." +boot directly to the kernel or to the bootloader. + +When DERIVATIONS-ONLY? is true, print the derivation file name(s) without +building anything." + (define println + (cut format #t "~a~%" <>)) + (mlet* %store-monad ((sys (system-derivation-for-action os action #:image-size image-size @@ -322,14 +328,17 @@ boot directly to the kernel or to the bootloader." (drvs -> (if (and grub? (memq action '(init reconfigure))) (list sys grub grub.cfg) (list sys))) - (% (maybe-build drvs #:dry-run? dry-run? - #:use-substitutes? use-substitutes?))) + (% (if derivations-only? + (return (for-each (compose println derivation-file-name) + drvs)) + (maybe-build drvs #:dry-run? dry-run? + #:use-substitutes? use-substitutes?)))) - (if dry-run? + (if (or dry-run? derivations-only?) (return #f) (begin - (for-each (cut format #t "~a~%" <>) - (map derivation->output-path drvs)) + (for-each (compose println derivation->output-path) + drvs) ;; Make sure GRUB is accessible. (when grub? @@ -383,6 +392,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (show-build-options-help) (display (_ " + -d, --derivation return the derivation of the given system")) + (display (_ " --on-error=STRATEGY apply STRATEGY when an error occurs while reading FILE")) (display (_ " @@ -425,6 +436,9 @@ Build the operating system declared in FILE according to ACTION.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix system"))) + (option '(#\d "derivation") #f #f + (lambda (opt name arg result) + (alist-cons 'derivations-only? #t result))) (option '("on-error") #t #f (lambda (opt name arg result) (alist-cons 'on-error (string->symbol arg) @@ -549,6 +563,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (set-guile-for-build (default-guile)) (perform-action action os #:dry-run? dry? + #:derivations-only? (assoc-ref opts + 'derivations-only?) #:use-substitutes? (assoc-ref opts 'substitutes?) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) diff --git a/guix/utils.scm b/guix/utils.scm index 1d4b2ff9b0..0802a1b67a 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> +;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -79,6 +80,7 @@ fold2 fold-tree fold-tree-leaves + split filtered-port compressed-port @@ -684,6 +686,23 @@ are connected to NODE in the tree, or '() or #f if NODE is a leaf node." (else result))) init children roots)) +(define (split lst e) + "Return two values, a list containing the elements of the list LST that +appear before the first occurence of the object E and a list containing the +elements after E." + (define (same? x) + (equal? e x)) + + (let loop ((rest lst) + (acc '())) + (match rest + (() + (values lst '())) + (((? same?) . tail) + (values (reverse acc) tail)) + ((head . tail) + (loop tail (cons head acc)))))) + ;;; ;;; Source location. diff --git a/m4/guix.m4 b/m4/guix.m4 index d464a478ca..842249a848 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -279,7 +279,7 @@ AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [ AC_CACHE_CHECK([libgcrypt's library directory], [guix_cv_libgcrypt_libdir], [if test "x$LIBGCRYPT_CONFIG" != "x"; then - guix_cv_libgcrypt_libdir=`$LIBGCRYPT_CONFIG --libs | sed -e "s/.*-L\([[^ ]]\+\)[[[:blank:]]]\+-lgcrypt.*/\1/g"` + guix_cv_libgcrypt_libdir=`$LIBGCRYPT_CONFIG --libs | grep -e -L | sed -e "s/.*-L\([[^ ]]\+\)[[[:blank:]]]\+-lgcrypt.*/\1/g"` else guix_cv_libgcrypt_libdir="" fi]) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index c0f169eca4..af46dac0e0 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -1,6 +1,7 @@ # List of source files which contain translatable strings. # This should be source files of the various tools, and not package modules. gnu/packages.scm +gnu/services.scm gnu/system.scm gnu/services/dmd.scm gnu/system/shadow.scm diff --git a/tests/containers.scm b/tests/containers.scm index 4783f8e8a5..0ba81491ba 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -34,6 +34,10 @@ (test-begin "containers") +(test-assert "call-with-container, exit with 0 when there is no error" + (zero? + (call-with-container '() (const #t) #:namespaces '(user)))) + (test-assert "call-with-container, user namespace" (zero? (call-with-container '() diff --git a/tests/gexp.scm b/tests/gexp.scm index 492f3d6d89..4860a8e79c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -619,6 +619,36 @@ (return (and (zero? (close-pipe pipe)) (= (expt n 2) (string->number str))))))) +(test-assertm "program-file" + (let* ((n (random (expt 2 50))) + (exp (gexp (begin + (use-modules (guix build utils)) + (display (ungexp n))))) + (file (program-file "program" exp + #:modules '((guix build utils)) + #:guile %bootstrap-guile))) + (mlet* %store-monad ((drv (lower-object file)) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (= n (string->number str))))))))) + +(test-assertm "scheme-file" + (let* ((text (plain-file "foo" "Hello, world!")) + (scheme (scheme-file "bar" #~(list "foo" #$text)))) + (mlet* %store-monad ((drv (lower-object scheme)) + (text (lower-object text)) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (mlet %store-monad ((refs ((store-lift references) out))) + (return (and (equal? refs (list text)) + (equal? `(list "foo" ,text) + (call-with-input-file out read))))))))) + (test-assert "text-file*" (let ((references (store-lift references))) (run-with-store %store @@ -643,6 +673,21 @@ file))))) #:guile-for-build (package-derivation %store %bootstrap-guile)))) +(test-assertm "mixed-text-file" + (mlet* %store-monad ((file -> (mixed-text-file "mixed" + "export PATH=" + %bootstrap-guile "/bin")) + (drv (lower-object file)) + (out -> (derivation->output-path drv)) + (guile-drv (package->derivation %bootstrap-guile)) + (guile -> (derivation->output-path guile-drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (mlet %store-monad ((refs ((store-lift references) out))) + (return (and (string=? (string-append "export PATH=" guile "/bin") + (call-with-input-file out get-string-all)) + (equal? refs (list guile)))))))) + (test-assert "gexp->derivation vs. %current-target-system" (let ((mval (gexp->derivation "foo" #~(begin @@ -661,6 +706,25 @@ (return (and (derivation? drv1) (derivation? drv2) (store-path? item))))) +(test-assertm "lower-object, computed-file" + (let* ((text (plain-file "foo" "Hello!")) + (exp #~(begin + (mkdir #$output) + (symlink #$%bootstrap-guile + (string-append #$output "/guile")) + (symlink #$text (string-append #$output "/text")))) + (computed (computed-file "computed" exp))) + (mlet* %store-monad ((text (lower-object text)) + (guile-drv (lower-object %bootstrap-guile)) + (comp-drv (lower-object computed)) + (comp -> (derivation->output-path comp-drv))) + (mbegin %store-monad + (built-derivations (list comp-drv)) + (return (and (string=? (readlink (string-append comp "/guile")) + (derivation->output-path guile-drv)) + (string=? (readlink (string-append comp "/text")) + text))))))) + (test-assert "printer" (string-match "^#<gexp \\(string-append .*#<package coreutils.*\ \"/bin/uname\"\\) [[:xdigit:]]+>$" diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 32faf71a4e..f91c78a801 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -40,7 +40,15 @@ test "`wc -l < "$tmpdir/a"`" = 1 cmp "$tmpdir/a" "$tmpdir/b" # Make sure the exit value is preserved. -if guix environment --ad-hoc guile-bootstrap --pure -E 'guile -c "(exit 42)"' +if guix environment --ad-hoc guile-bootstrap --pure -- guile -c '(exit 42)' +then + false +else + test $? = 42 +fi + +# Same as above, but with deprecated -E flag. +if guix environment --ad-hoc guile-bootstrap --pure -E "guile -c '(exit 42)'" then false else @@ -66,7 +74,7 @@ then # as returned by '--search-paths'. guix environment -e '(@@ (gnu packages commencement) gnu-make-boot0)' \ --no-substitutes --pure \ - --exec='echo $PATH $CPATH $LIBRARY_PATH' > "$tmpdir/b" + -- /bin/sh -c 'echo $PATH $CPATH $LIBRARY_PATH' > "$tmpdir/b" ( . "$tmpdir/a" ; echo $PATH $CPATH $LIBRARY_PATH ) > "$tmpdir/c" cmp "$tmpdir/b" "$tmpdir/c" diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 4289db2390..d99c9bd07b 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -132,6 +132,12 @@ EOF make_user_config "users" "wheel" guix system build "$tmpfile" -n # succeeds +guix system build "$tmpfile" -d # succeeds +guix system build "$tmpfile" -d | grep '\.drv$' + +guix system vm "$tmpfile" -d # succeeds +guix system vm "$tmpfile" -d | grep '\.drv$' + make_user_config "group-that-does-not-exist" "users" if guix system build "$tmpfile" -n 2> "$errorfile" then false diff --git a/tests/services.scm b/tests/services.scm new file mode 100644 index 0000000000..b4e2cb0b30 --- /dev/null +++ b/tests/services.scm @@ -0,0 +1,91 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-services) + #:use-module (gnu services) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-64)) + +(test-begin "services") + +(test-equal "fold-services" + ;; Make sure 'fold-services' returns the right result. The numbers come + ;; from services of type T3; 'xyz 60' comes from the service of type T2, + ;; where 60 = 15 × 4 = (1 + 2 + 3 + 4 + 5) × 4. + '(initial-value 5 4 3 2 1 xyz 60) + (let* ((t1 (service-type (name 't1) (extensions '()) + (compose concatenate) + (extend cons))) + (t2 (service-type (name 't2) + (extensions + (list (service-extension t1 + (cut list 'xyz <>)))) + (compose (cut reduce + 0 <>)) + (extend *))) + (t3 (service-type (name 't3) + (extensions + (list (service-extension t2 identity) + (service-extension t1 list))))) + (r (fold-services (cons* (service t1 'initial-value) + (service t2 4) + (map (lambda (x) + (service t3 x)) + (iota 5 1))) + #:target-type t1))) + (and (eq? (service-kind r) t1) + (service-parameters r)))) + +(test-assert "fold-services, ambiguity" + (let* ((t1 (service-type (name 't1) (extensions '()) + (compose concatenate) + (extend cons))) + (t2 (service-type (name 't2) + (extensions + (list (service-extension t1 list))))) + (s (service t2 42))) + (guard (c ((ambiguous-target-service-error? c) + (and (eq? (ambiguous-target-service-error-target-type c) + t1) + (eq? (ambiguous-target-service-error-service c) + s)))) + (fold-services (list (service t1 'first) + (service t1 'second) + s) + #:target-type t1) + #f))) + +(test-assert "fold-services, missing target" + (let* ((t1 (service-type (name 't1) (extensions '()))) + (t2 (service-type (name 't2) + (extensions + (list (service-extension t1 list))))) + (s (service t2 42))) + (guard (c ((missing-target-service-error? c) + (and (eq? (missing-target-service-error-target-type c) + t1) + (eq? (missing-target-service-error-service c) + s)))) + (fold-services (list s) #:target-type t1) + #f))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) diff --git a/tests/utils.scm b/tests/utils.scm index 115868c857..b65d6d20ba 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -121,6 +121,20 @@ '(0 1 2 3))) list)) +(test-equal "split, element is in list" + '((foo) (baz)) + (call-with-values + (lambda () + (split '(foo bar baz) 'bar)) + list)) + +(test-equal "split, element is not in list" + '((foo bar baz) ()) + (call-with-values + (lambda () + (split '(foo bar baz) 'quux)) + list)) + (test-equal "strip-keyword-arguments" '(a #:b b #:c c) (strip-keyword-arguments '(#:foo #:bar #:baz) |