From be1c2c54d9f918f50f71c6d32a72d4498c07504c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
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 <service>.
* gnu/services/base.scm (root-file-system-service, file-system-service,
  user-unmount-service, user-processes-service, host-name-service,
  console-keymap-service, console-font-service, mingetty-service,
  nscd.conf-file, nscd-service): Likewise.
  (%default-syslog.conf): New variable.
  (syslog-service): Use it.  Turn into a regular procedure.
  (guix-service, udev-rules-union, kvm-udev-rule, udev-service,
  device-mapping-service, swap-service): Likewise.
* gnu/services/databases.scm (%default-postgres-hba,
  %default-postgres-ident): Use 'plain-file' instead of 'text-file'.
  (%default-postgres-config): Use 'mixed-text-file' instead of
  'text-file*'.
  (postgresql-service):  Use 'program-file' instead of 'gexp->script'.
  Turn into a regular procedure.
* gnu/services/desktop.scm (dbus-configuration-directory): Use
  'computed-file' instead of 'gexp->derivation'.
  (upower-configuration-file, geoclue-configuration-file,
  elogind-configuration-file): Use 'plain-file' instead of 'text-file'.
  (dbus-service, upower-service, colord-service, geoclue-service,
  polkit-service, elogind-service): Turn into regular procedures.
  (%desktop-services): Remove use of 'mlet' when iterating on
  %BASE-SERVICES.
* gnu/services/lirc.scm (lirc-service): Turn into a regular procedure.
* gnu/services/networking.scm (static-networking-service,
  dhcp-client-service, ntp-service, tor-service, bitlbee-service,
  wicd-service): Likewise.
* gnu/services/ssh.scm (lsh-service): Likewise.
* gnu/services/web.scm (nginx-service): Likewise.
* gnu/services/xorg.scm (xorg-configuration-file): Use 'mixed-text-file'
  instead of 'text-file*'.
  (xorg-start-command, slim-service): Turn into regular procedures.
  (xinitrc): Use 'program-file' instead of 'gexp->script'.
* gnu/system/install.scm (cow-store-service,
  configuration-template-service): Turn into regular procedures.
* gnu/system.scm (other-file-system-services, device-mapping-services,
  swap-services, essential-services, operating-system-services,
  user-shells, operating-system-accounts): Remove now unnecessary
  'mlet' and turn into regular procedures.
  (operating-system-etc-directory, operating-system-activation-script,
  operating-system-boot-script): Adjust accordingly.
* doc/guix.texi (Base Services, Networking Services, X Window, Desktop
  Services, Database Services, Web Services, Various Services, Name
  Service Switch): Adjust accordingly.
---
 gnu/services/networking.scm | 357 +++++++++++++++++++++-----------------------
 1 file changed, 173 insertions(+), 184 deletions(-)

(limited to 'gnu/services/networking.scm')

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
-- 
cgit v1.2.3