From be1c2c54d9f918f50f71c6d32a72d4498c07504c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 9 Sep 2015 09:17:31 +0200 Subject: system: Make service procedures non-monadic. * gnu/services/avahi.scm (configuration-file): Use 'plain-file' instead of 'text-file'. (avahi-service): Turn into a regular procedure that returns a . * gnu/services/base.scm (root-file-system-service, file-system-service, user-unmount-service, user-processes-service, host-name-service, console-keymap-service, console-font-service, mingetty-service, nscd.conf-file, nscd-service): Likewise. (%default-syslog.conf): New variable. (syslog-service): Use it. Turn into a regular procedure. (guix-service, udev-rules-union, kvm-udev-rule, udev-service, device-mapping-service, swap-service): Likewise. * gnu/services/databases.scm (%default-postgres-hba, %default-postgres-ident): Use 'plain-file' instead of 'text-file'. (%default-postgres-config): Use 'mixed-text-file' instead of 'text-file*'. (postgresql-service): Use 'program-file' instead of 'gexp->script'. Turn into a regular procedure. * gnu/services/desktop.scm (dbus-configuration-directory): Use 'computed-file' instead of 'gexp->derivation'. (upower-configuration-file, geoclue-configuration-file, elogind-configuration-file): Use 'plain-file' instead of 'text-file'. (dbus-service, upower-service, colord-service, geoclue-service, polkit-service, elogind-service): Turn into regular procedures. (%desktop-services): Remove use of 'mlet' when iterating on %BASE-SERVICES. * gnu/services/lirc.scm (lirc-service): Turn into a regular procedure. * gnu/services/networking.scm (static-networking-service, dhcp-client-service, ntp-service, tor-service, bitlbee-service, wicd-service): Likewise. * gnu/services/ssh.scm (lsh-service): Likewise. * gnu/services/web.scm (nginx-service): Likewise. * gnu/services/xorg.scm (xorg-configuration-file): Use 'mixed-text-file' instead of 'text-file*'. (xorg-start-command, slim-service): Turn into regular procedures. (xinitrc): Use 'program-file' instead of 'gexp->script'. * gnu/system/install.scm (cow-store-service, configuration-template-service): Turn into regular procedures. * gnu/system.scm (other-file-system-services, device-mapping-services, swap-services, essential-services, operating-system-services, user-shells, operating-system-accounts): Remove now unnecessary 'mlet' and turn into regular procedures. (operating-system-etc-directory, operating-system-activation-script, operating-system-boot-script): Adjust accordingly. * doc/guix.texi (Base Services, Networking Services, X Window, Desktop Services, Database Services, Web Services, Various Services, Name Service Switch): Adjust accordingly. --- doc/guix.texi | 66 ++-- gnu/services/avahi.scm | 88 +++-- gnu/services/base.scm | 908 +++++++++++++++++++++----------------------- gnu/services/databases.scm | 74 ++-- gnu/services/desktop.scm | 450 +++++++++++----------- gnu/services/lirc.scm | 45 +-- gnu/services/networking.scm | 357 +++++++++-------- gnu/services/ssh.scm | 34 +- gnu/services/web.scm | 37 +- gnu/services/xorg.scm | 129 +++---- gnu/system.scm | 104 +++-- gnu/system/install.scm | 84 ++-- 12 files changed, 1147 insertions(+), 1229 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index d5c5ffd8cc..f31f07d49d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5749,11 +5749,11 @@ 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] @ +@deffn {Scheme 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}. @@ -5774,7 +5774,7 @@ the ``message of the day''. @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{} object. @@ -5861,13 +5861,13 @@ 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] @ +@deffn {Scheme Procedure} guix-service [#:guix guix] @ [#:builder-group "guixbuild"] [#:build-accounts 10] @ [#:authorize-hydra-key? #t] [#:use-substitutes? #t] @ [#:extra-options '()] @@ -5886,11 +5886,11 @@ Finally, @var{extra-options} is a list of additional command-line options passed to @command{guix-daemon}. @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 @@ -5903,12 +5903,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 @@ -5916,12 +5916,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 @@ -5932,14 +5932,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 @@ -5956,7 +5956,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] @ @@ -6023,7 +6023,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 '()] @@ -6053,7 +6053,7 @@ Xorg---is provided by the @code{(gnu services xorg)} module. Note that there is no @code{xorg-service} procedure. Instead, the X server is 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}] @@ -6089,7 +6089,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 @@ -6099,7 +6099,7 @@ file or a derivation that builds it; when omitted, the result of Usually the X server is started by a login manager. @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. @@ -6150,7 +6150,7 @@ Reference, @code{services}}). The actual service definitions provided by @code{(gnu services desktop)} are described below. -@deffn {Monadic Procedure} dbus-service @var{services} @ +@deffn {Scheme Procedure} dbus-service @var{services} @ [#:dbus @var{dbus}] Return a service that runs the ``system bus'', using @var{dbus}, with support for @var{services}. @@ -6165,7 +6165,7 @@ and policy files. For example, to allow avahi-daemon to use the system bus, @var{services} must be equal to @code{(list avahi)}. @end deffn -@deffn {Monadic Procedure} elogind-service @ +@deffn {Scheme Procedure} elogind-service @ [#:elogind @var{elogind}] [#:config @var{config}] Return a service that runs the @code{elogind} login and seat management daemon. @uref{https://github.com/andywingo/elogind, @@ -6236,7 +6236,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 @@ -6246,7 +6246,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] @ @@ -6265,7 +6265,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 @@ -6293,7 +6293,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] @@ -6313,7 +6313,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. @@ -6328,7 +6328,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] @@ -6348,7 +6348,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 @@ -6521,13 +6521,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 diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index a3ca5ab6fb..929ac2fbb6 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -21,7 +21,6 @@ #: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 gexp) #:export (avahi-service)) @@ -39,21 +38,21 @@ (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") - "") + (plain-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?))))) + "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* (avahi-service #:key (avahi avahi) host-name @@ -76,37 +75,36 @@ When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled. Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6 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)) + (let ((config (configuration-file #:host-name host-name + #:publish? publish? + #:ipv4? ipv4? + #:ipv6? ipv6? + #:wide-area? wide-area? + #:domains-to-browse + domains-to-browse))) + (service + (documentation "Run the Avahi mDNS/DNS-SD responder.") + (provision '(avahi-daemon)) + (requirement '(dbus-system networking)) - (start #~(make-forkexec-constructor - (list (string-append #$avahi "/sbin/avahi-daemon") - "--syslog" "-f" #$config))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/avahi-daemon"))) + (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"))))))))) + (user-groups (list (user-group + (name "avahi") + (system? #t)))) + (user-accounts (list (user-account + (name "avahi") + (group "avahi") + (system? #t) + (comment "Avahi daemon user") + (home-directory "/var/empty") + (shell + #~(string-append #$shadow "/sbin/nologin")))))))) ;;; avahi.scm ends here diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 865d461a1e..799526ce2a 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -35,7 +35,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) @@ -80,41 +79,39 @@ system upon shutdown (aka. cleanly \"umounting\" root.) This service must be the root of the service dependency graph so that its '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))))) + (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) @@ -127,79 +124,75 @@ true, check the file system before mounting it. When CREATE-MOUNT-POINT? is true, create TARGET if it does not exist yet. FLAGS is a list of symbols, 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 , 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)))))) + (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 , 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 - (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))) - - ;; Make sure we don't keep the user's mount points busy. - (chdir "/") - - (for-each (lambda (mount-point) - (format #t "unmounting '~a'...~%" mount-point) - (catch 'system-error - (lambda () - (umount mount-point)) - (lambda args - (let ((errno (system-error-errno args))) - (format #t "failed to unmount '~a': ~a~%" - mount-point (strerror errno)))))) - (filter (negate known?) (mount-points))) - #f)))))) + (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))) + + ;; Make sure we don't keep the user's mount points busy. + (chdir "/") + + (for-each (lambda (mount-point) + (format #t "unmounting '~a'...~%" mount-point) + (catch 'system-error + (lambda () + (umount mount-point)) + (lambda args + (let ((errno (system-error-errno args))) + (format #t "failed to unmount '~a': ~a~%" + mount-point (strerror errno)))))) + (filter (negate known?) (mount-points))) + #f)))) (define %do-not-kill-file ;; Name of the file listing PIDs of processes that must survive when halting @@ -217,86 +210,84 @@ listed in REQUIREMENTS. All the services that spawn processes must depend on this one so that they are 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 . - (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\ + (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 . + (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)))) + pids) + (sleep* 2) + (wait)))) - (display "all processes have been terminated\n") - #f)) - (respawn? #f))))) + (display "all processes have been terminated\n") + #f)) + (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 + (documentation "Initialize the machine's host name.") + (provision '(host-name)) + (start #~(lambda _ + (sethostname #$name))) + (respawn? #f))) (define (unicode-start tty) "Return a gexp to start Unicode support on @var{tty}." @@ -318,16 +309,13 @@ stopped before 'kill' is called." (define (console-keymap-service file) "Return a service to load console keymap from @var{file}." - (with-monad %store-monad - (return - (service - (documentation - (string-append "Load console keymap (loadkeys).")) - (provision '(console-keymap)) - (start #~(lambda _ - (zero? (system* (string-append #$kbd "/bin/loadkeys") - #$file)))) - (respawn? #f))))) + (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-font-service tty #:optional (font "LatGrkCyr-8x16")) "Return a service that sets up Unicode support in @var{tty} and loads @@ -336,24 +324,23 @@ stopped before 'kill' is called." ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode ;; 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)))))) + (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 @@ -379,38 +366,36 @@ of the log-in program (the default is the @code{login} program from the Shadow tool suite.) @var{motd} is a file-like object to use as the ``message of the day''." - (with-monad %store-monad - (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 + (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))))) (define-record-type* nscd-configuration make-nscd-configuration @@ -472,44 +457,44 @@ tool suite.) @code{} object." (define cache->config (match-lambda - (($ (= 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"))))) + (($ (= 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 (($ 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))))))) + (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)) @@ -518,39 +503,35 @@ tool suite.) given @var{config}---an @code{} 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." - - ;; Snippet adapted from the GNU inetutils manual. - (define contents " + (let ((nscd.conf (nscd.conf-file config))) + (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)))) + +;; 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. @@ -569,20 +550,19 @@ 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 + (documentation "Run the syslog daemon (syslogd).") + (provision '(syslogd)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$inetutils "/libexec/syslogd") + "--no-detach" "--rcfile" #$config-file))) + (stop #~(make-kill-destructor)))) (define* (guix-build-accounts count #:key (group "guixbuild") @@ -658,36 +638,34 @@ passed to @command{guix-daemon}." (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))))) + (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 (udev-rules-union packages) "Return the union of the @code{lib/udev/rules.d} directories found in each @@ -712,124 +690,125 @@ item of @var{packages}." (union-build (string-append #$output "/lib/udev/rules.d") (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 - ;; , 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 + ;; , for background.) + (display "\ KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port)))) - #:modules '((guix build utils)))) + #:modules '((guix build utils)))) (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 - ;; . - (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))))) + (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)))))) + (service + (provision '(udev)) + + ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can + ;; be added: see + ;; . + (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 (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 + (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 (swap-service device) "Return a service that uses @var{device} as a swap device." @@ -839,18 +818,17 @@ gexp, to open it, and evaluate @var{close} to close it." (string->symbol (basename device)))) '())) - (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 + (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 %base-services ;; Convenience variable holding the basic services. diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index 18f41e74da..20f8a6977e 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 +;;; Copyright © 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +23,6 @@ #: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) #:export (postgresql-service)) @@ -34,23 +34,20 @@ ;;; Code: (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-service #:key (postgresql postgresql) (config-file %default-postgres-config) @@ -62,16 +59,15 @@ and stores the database cluster in @var{data-directory}." ;; Wrapper script that switches to the 'postgres' user before launching ;; 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))))) + (program-file "start-postgres" + #~(let ((user (getpwnam "postgres")) + (postgres (string-append #$postgresql + "/bin/postgres"))) + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + (system* postgres + (string-append "--config-file=" #$config-file) + "-D" #$data-directory)))) (define activate #~(begin @@ -99,23 +95,21 @@ and stores the database cluster in @var{data-directory}." (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 + (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"))))))) diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index b91bdd8ad3..35b19146dd 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -35,7 +35,6 @@ #: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 store) #:use-module (guix gexp) @@ -104,7 +103,7 @@ (sxml->xml (services->sxml (list #$@services)) port))))) - (gexp->derivation "dbus-configuration" build)) + (computed-file "dbus-configuration" build)) (define* (dbus-service services #:key (dbus dbus)) "Return a service that runs the \"system bus\", using @var{dbus}, with @@ -118,50 +117,49 @@ be notified of system-wide events. @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration 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))))))))))) + (let ((conf (dbus-configuration-directory dbus services))) + (service + (documentation "Run the D-Bus system daemon.") + (provision '(dbus-system)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$dbus "/bin/dbus-daemon") + "--nofork" + (string-append "--config-file=" #$conf "/system.conf")))) + (stop #~(make-kill-destructor)) + (user-groups (list (user-group + (name "messagebus") + (system? #t)))) + (user-accounts (list (user-account + (name "messagebus") + (group "messagebus") + (system? #t) + (comment "D-Bus system bus user") + (home-directory "/var/run/dbus") + (shell + #~(string-append #$shadow "/sbin/nologin"))))) + (activate #~(begin + (use-modules (guix build utils)) + + (mkdir-p "/var/run/dbus") + + (let ((user (getpwnam "messagebus"))) + (chown "/var/run/dbus" + (passwd:uid user) (passwd:gid user))) + + (unless (file-exists? "/etc/machine-id") + (format #t "creating /etc/machine-id...~%") + (let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) + ;; XXX: We can't use 'system' because the initrd's + ;; guile system(3) only works when 'sh' is in $PATH. + (let ((pid (primitive-fork))) + (if (zero? pid) + (call-with-output-file "/etc/machine-id" + (lambda (port) + (close-fdes 1) + (dup2 (port->fdes port) 1) + (execl prog))) + (waitpid pid)))))))))) ;;; @@ -175,24 +173,24 @@ and policy files. For example, to allow avahi-daemon to use the system bus, 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"))) + (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-service #:key (upower upower) (watts-up-pro? #f) @@ -210,47 +208,46 @@ and policy files. For example, to allow avahi-daemon to use the system bus, @command{upowerd}}, a system-wide monitor for power consumption and battery 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-file + #:watts-up-pro? watts-up-pro? + #:poll-batteries? poll-batteries? + #:ignore-lid? ignore-lid? + #:use-percentage-for-policy? use-percentage-for-policy? + #:percentage-low percentage-low + #:percentage-critical percentage-critical + #:percentage-action percentage-action + #:time-low time-low + #:time-critical time-critical + #:time-action time-action + #:critical-power-action critical-power-action))) + (service + (documentation "Run the UPower power and battery monitor.") + (provision '(upower-daemon)) + (requirement '(dbus-system udev)) + + (start #~(make-forkexec-constructor + (list (string-append #$upower "/libexec/upowerd")) + #:environment-variables + (list (string-append "UPOWER_CONF_FILE_NAME=" #$config)))) + (stop #~(make-kill-destructor)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/upower") + (let ((user (getpwnam "upower"))) + (chown "/var/lib/upower" + (passwd:uid user) (passwd:gid user))))) + + (user-groups (list (user-group + (name "upower") + (system? #t)))) + (user-accounts (list (user-account + (name "upower") + (group "upower") + (system? #t) + (comment "UPower daemon user") + (home-directory "/var/empty") + (shell + #~(string-append #$shadow "/sbin/nologin")))))))) ;;; @@ -263,34 +260,32 @@ interface to manage the color profiles of input and output devices such as screens and scanners. It is notably used by the GNOME Color Manager graphical 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 + (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"))))))) ;;; @@ -321,16 +316,16 @@ users are allowed." wifi-submission-url submission-nick applications) "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 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")))) (define* (geoclue-service #:key (geoclue geoclue) (whitelist '()) @@ -350,37 +345,36 @@ and Epiphany web browsers are able to ask for the user's location, and in the case of Icecat and Epiphany, both will ask the user for permission first. See @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")))))))) + (let ((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))) + (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"))))))) ;;; @@ -393,30 +387,28 @@ service. By querying the @command{polkit} service, a privileged system component can know when it should grant additional capabilities to ordinary 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 + (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"))))) ;;; @@ -520,7 +512,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]" @@ -562,18 +554,17 @@ service. The @command{elogind} service integrates with PAM to allow other system components to know the set of logged-in users as well as their session 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)))))) + (let ((config-file (elogind-configuration-file config))) + (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))))) ;;; @@ -599,25 +590,24 @@ when they log out." (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)))) + (map (lambda (service) + (cond + ;; Provide an nscd ready to use nss-mdns. + ((memq 'nscd (service-provision service)) + (nscd-service (nscd-configuration) + #:name-services (list nss-mdns))) + + ;; Add more rules to udev-service. + ;; + ;; XXX Keep this in sync with the 'udev-service' call in + ;; %base-services. Here we intend only to add 'upower', + ;; 'colord', and 'elogind'. + ((memq 'udev (service-provision service)) + (udev-service #:rules + (list lvm2 fuse alsa-utils crda + upower colord elogind))) + + (else service))) %base-services))) ;;; desktop.scm ends here diff --git a/gnu/services/lirc.scm b/gnu/services/lirc.scm index 857f362db7..368f2ba293 100644 --- a/gnu/services/lirc.scm +++ b/gnu/services/lirc.scm @@ -19,7 +19,6 @@ (define-module (gnu services lirc) #:use-module (gnu services) #:use-module (gnu packages lirc) - #:use-module (guix monads) #:use-module (guix store) #:use-module (guix gexp) #:export (lirc-service)) @@ -41,28 +40,26 @@ The daemon will use specified @var{device}, @var{driver} and Finally, @var{extra-options} is a list of additional command-line options 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 + (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"))))) ;;; lirc.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index c2b404503e..50ffac5796 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -28,7 +28,6 @@ #:use-module (gnu packages wicd) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (srfi srfi-26) #:export (%facebook-host-aliases static-networking-service @@ -93,54 +92,52 @@ gateway." ;; 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) - (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 + (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") - "del" "-net" "default") - #t)))) - (respawn? #f))))) + "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* (dhcp-client-service #:key (dhcp isc-dhcp)) "Return a service that runs @var{dhcp}, a Dynamic Host Configuration @@ -152,52 +149,49 @@ Protocol (DHCP) client, on all the non-loopback network interfaces." (define pid-file "/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 + (documentation "Set up networking via DHCP.") + (requirement '(user-processes udev)) + + ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when + ;; networking is unavailable, but also means that the interface is not up + ;; yet when 'start' completes. To wait for the interface to be ready, one + ;; should instead monitor udev events. + (provision '(networking)) + + (start #~(lambda _ + ;; When invoked without any arguments, 'dhclient' discovers all + ;; non-loopback interfaces *that are up*. However, the relevant + ;; interfaces are typically down at this point. Thus we perform + ;; our own interface discovery here. + (define valid? + (negate loopback-network-interface?)) + (define ifaces + (filter valid? (all-network-interface-names))) + + ;; XXX: Make sure the interfaces are up so that 'dhclient' can + ;; actually send/receive over them. + (for-each set-network-interface-up ifaces) + + (false-if-exception (delete-file #$pid-file)) + (let ((pid (fork+exec-command + (cons* #$dhclient "-nw" + "-pf" #$pid-file ifaces)))) + (and (zero? (cdr (waitpid pid))) + (let loop () + (catch 'system-error + (lambda () + (call-with-input-file #$pid-file read)) + (lambda args + ;; 'dhclient' returned before PID-FILE was created, + ;; so try again. + (let ((errno (system-error-errno args))) + (if (= ENOENT errno) + (begin + (sleep 1) + (loop)) + (apply throw args)))))))))) + (stop #~(make-kill-destructor)))) (define %ntp-servers ;; Default set of NTP servers. @@ -227,57 +221,55 @@ restrict -6 default kod nomodify notrap nopeer noquery restrict 127.0.0.1 restrict -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"))))))))) + (let ((ntpd.conf (plain-file "ntpd.conf" config))) + (service + (provision '(ntpd)) + (documentation "Run the Network Time Protocol (NTP) daemon.") + (requirement '(user-processes networking)) + (start #~(make-forkexec-constructor + (list (string-append #$ntp "/bin/ntpd") "-n" + "-c" #$ntpd.conf + "-u" "ntpd"))) + (stop #~(make-kill-destructor)) + (user-accounts (list (user-account + (name "ntpd") + (group "nogroup") + (system? #t) + (comment "NTP daemon user") + (home-directory "/var/empty") + (shell + #~(string-append #$shadow "/sbin/nologin")))))))) (define* (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."))))) + (let ((torrc (plain-file "torrc" "User tor\n"))) + (service + (provision '(tor)) + + ;; Tor needs at least one network interface to be up, hence the + ;; dependency on 'loopback'. + (requirement '(user-processes loopback)) + + (start #~(make-forkexec-constructor + (list (string-append #$tor "/bin/tor") "-f" #$torrc))) + (stop #~(make-kill-destructor)) + + (user-groups (list (user-group + (name "tor") + (system? #t)))) + (user-accounts (list (user-account + (name "tor") + (group "tor") + (system? #t) + (comment "Tor daemon user") + (home-directory "/var/empty") + (shell + #~(string-append #$shadow "/sbin/nologin"))))) + + (documentation "Run the Tor anonymous network overlay.")))) (define* (bitlbee-service #:key (bitlbee bitlbee) (interface "127.0.0.1") (port 6667) @@ -292,60 +284,57 @@ come from any networking interface. In addition, @var{extra-settings} specifies a string to append to the configuration file." - (mlet %store-monad ((conf (text-file "bitlbee.conf" - (string-append " + (let ((conf (plain-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 + (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")))))))) (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 + (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))))))) ;;; networking.scm ends here diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index e2f85421e9..3fa0976054 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -19,7 +19,6 @@ (define-module (gnu services ssh) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (gnu services) #:use-module (gnu system linux) ; 'pam-service' #:use-module (gnu packages lsh) @@ -152,22 +151,21 @@ The other options should be self-descriptive." '(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 + (documentation "GNU lsh SSH server") + (provision '(ssh-daemon)) + (requirement requires) + (start #~(make-forkexec-constructor (list #$@lsh-command))) + (stop #~(make-kill-destructor)) + (pam-services + (list (unix-pam-service + "lshd" + #:allow-empty-passwords? allow-empty-passwords?))) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/spool/lsh") + #$(if initialize? + (activation lsh host-key) + #t))))) ;;; ssh.scm ends here diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 2db5b76ce4..c6b4153d05 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -22,7 +22,6 @@ #: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) #:export (nginx-service)) @@ -76,22 +75,20 @@ files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY." (define nologin #~(string-append #$shadow "/sbin/nologin")) ;; 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 + (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)))))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 9ee88170e4..9c96aab2b8 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -31,7 +31,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 +62,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 +86,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 +127,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 +135,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 +196,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)) ;;; @@ -224,7 +220,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}. @@ -251,13 +247,9 @@ If @var{theme} is @code{#f}, the use the default log-in theme; otherwise theme to use. In that case, @var{theme-name} specifies the name of the theme." - (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" " + (define slim.cfg + (let ((xinitrc (xinitrc #:fallback-session auto-login-session))) + (mixed-text-file "slim.cfg" " default_path /run/current-system/profile/bin default_xserver " startx " xserver_arguments :0 vt7 @@ -271,40 +263,37 @@ 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?))))))) +reboot_cmd " dmd "/sbin/reboot\n" + (if auto-login? + (string-append "auto_login yes\ndefault_user " default-user "\n") + "") + (if theme-name + (string-append "current_theme " theme-name "\n") + "")))) + + (service + (documentation "Xorg display server") + (provision '(xorg-server)) + (requirement '(user-processes host-name udev)) + (start + #~(lambda () + ;; A stale lock file can prevent SLiM from starting, so remove it + ;; to be on the safe side. + (false-if-exception (delete-file "/var/run/slim.lock")) + + (fork+exec-command + (list (string-append #$slim "/bin/slim") "-nodaemon") + #:environment-variables + (list (string-append "SLIM_CFGFILE=" #$slim.cfg) + #$@(if theme + (list #~(string-append "SLIM_THEMESDIR=" #$theme)) + #~()))))) + (stop #~(make-kill-destructor)) + (respawn? #t) + (pam-services + ;; Tell PAM about 'slim'. + (list (unix-pam-service + "slim" + #:allow-empty-passwords? allow-empty-passwords?))))) ;;; xorg.scm ends here diff --git a/gnu/system.scm b/gnu/system.scm index cee5f37bcb..92a3ca3e6e 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -244,19 +244,18 @@ as 'needed-for-boot'." (string->symbol (mapped-device-target md)))) (device-mappings fs)))) - (sequence %store-monad - (map (lambda (fs) - (match fs - (($ 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 (lambda (fs) + (match fs + (($ device title target type flags opts + #f check? create?) + (file-system-service device target type + #:title title + #:requirements (requirements fs) + #:check? check? + #:create-mount-point? create? + #:options opts + #:flags flags)))) + file-systems)) (define (mapped-device-user device file-systems) "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f." @@ -287,23 +286,21 @@ 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) "Return the list of essential services for OS. These are special services @@ -312,26 +309,23 @@ bookkeeping." (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))))) + (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 (compose first service-provision) + other-fs))) + (host-name (host-name-service (operating-system-host-name os)))) + (cons* host-name procs root-fs unmount + (append other-fs mappings swaps)))) (define (operating-system-services os) "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))) ;;; @@ -420,8 +414,7 @@ settings for 'guix.el' to work out-of-the-box." (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 @@ -577,9 +570,9 @@ fi\n")) (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))))) + (append users + (append-map service-user-accounts + (operating-system-services os)))) (define (maybe-string->file file-name thing) "If THING is a string, return a with THING as its content. @@ -615,7 +608,7 @@ 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)) + ((services -> (operating-system-services os)) (pam-services -> ;; Services known to PAM. (append (operating-system-pam-services os) @@ -626,7 +619,7 @@ use 'plain-file' instead~%") "hosts" (or (operating-system-hosts-file os) (default-/etc/hosts (operating-system-host-name os))))) - (shells (user-shells os))) + (shells -> (user-shells os))) (etc-directory #:pam-services pam-services #:skeletons skeletons #:issue (operating-system-issue os) @@ -713,7 +706,7 @@ etc." (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>) gexps)))) - (mlet* %store-monad ((services (operating-system-services os)) + (mlet* %store-monad ((services -> (operating-system-services os)) (actions (service-activations services)) (etc (operating-system-etc-directory os)) (modules (imported-modules %modules)) @@ -721,7 +714,7 @@ etc." (modprobe (modprobe-wrapper)) (firmware (directory-union "firmware" (operating-system-firmware os))) - (accounts (operating-system-accounts os))) + (accounts -> (operating-system-accounts os))) (define setuid-progs (operating-system-setuid-programs os)) @@ -789,9 +782,8 @@ etc." "Return the boot script for OS---i.e., the code started by the initrd once 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?)) + (mlet* %store-monad ((services -> (operating-system-services os)) + (activate (operating-system-activation-script os)) (dmd-conf (dmd-configuration-file services))) (gexp->file "boot" #~(begin diff --git a/gnu/system/install.scm b/gnu/system/install.scm index dc5a47a293..1ba36c394b 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -163,32 +163,31 @@ current store is on a RAM disk." "Return a service that makes the store copy-on-write, such that writes go to the user's target storage device rather than on the RAM disk." ;; See 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 \ + (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)))))))) + ;; 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 @@ -204,25 +203,24 @@ configuration template file in the installation system." '(("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))))))) + (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. -- cgit v1.2.3