02/09: services: boot: Take gexps instead of monadic gexps.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 378daa8cb677121e1893f9173af1db060720d6e4
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jun 20 11:01:07 2018 +0200

    services: boot: Take gexps instead of monadic gexps.
    
    * gnu/services.scm (compute-boot-script): Rename 'mexps' to 'gexps' and
    remove 'mlet' form.
    (boot-service-type): Update comment.
    (cleanup-gexp): Remove 'with-monad' and 'return'.
    (activation-script): Rewrite in non-monadic style: use 'scheme-file'
    instead of 'gexp->file'.
    (gexps->activation-gexp): Remove 'mlet', return a gexp.
    * gnu/services/shepherd.scm (shepherd-boot-gexp): Remove 'with-monad'
    and 'return'.
    * gnu/system.scm (operating-system-boot-script): Remove outdated comment.
    * gnu/tests/base.scm (%cleanup-os): For 'dirty-service', remove
    'with-monad' and 'return'.
---
 gnu/services.scm          | 164 ++++++++++++++++++++++------------------------
 gnu/services/shepherd.scm |  40 ++++++-----
 gnu/system.scm            |   1 -
 gnu/tests/base.scm        |  27 ++++----
 4 files changed, 110 insertions(+), 122 deletions(-)

diff --git a/gnu/services.scm b/gnu/services.scm
index 51edb48..49cf01a 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -337,15 +337,14 @@ containing the given entries."
 turn refers to everything the operating system needs: its kernel, initrd,
 system profile, boot script, and so on.")))
 
-(define (compute-boot-script _ mexps)
-  ;; Reverse MEXPS so that extensions appear in the boot script in the right
+(define (compute-boot-script _ gexps)
+  ;; Reverse GEXPS so that extensions appear in the boot script in the right
   ;; order.  That is, user extensions would come first, and extensions added
   ;; by 'essential-services' (e.g., running shepherd) are guaranteed to come
   ;; last.
-  (mlet %store-monad ((gexps (sequence %store-monad (reverse mexps))))
-    (gexp->file "boot"
-                ;; Clean up and activate the system, then spawn shepherd.
-                #~(begin address@hidden))))
+  (gexp->file "boot"
+              ;; Clean up and activate the system, then spawn shepherd.
+              #~(begin #$@(reverse gexps))))
 
 (define (boot-script-entry mboot)
   "Return, as a monadic value, an entry for the boot script in the system
@@ -354,9 +353,9 @@ directory."
     (return `(("boot" ,boot)))))
 
 (define boot-service-type
-  ;; The service of this type is extended by being passed gexps as monadic
-  ;; values.  It aggregates them in a single script, as a monadic value, which
-  ;; becomes its 'parameters'.  It is the only service that extends nothing.
+  ;; The service of this type is extended by being passed gexps.  It
+  ;; aggregates them in a single script, as a monadic value, which becomes its
+  ;; value.
   (service-type (name 'boot)
                 (extensions
                  (list (service-extension system-service-type
@@ -372,48 +371,46 @@ by the initrd once the root file system is mounted.")))
   (service boot-service-type #t))
 
 (define (cleanup-gexp _)
-  "Return as a monadic value a gexp to clean up /tmp and similar places upon
-boot."
-  (with-monad %store-monad
-    (with-imported-modules '((guix build utils))
-      (return #~(begin
-                  (use-modules (guix build utils))
-
-                  ;; Clean out /tmp and /var/run.
-                  ;;
-                  ;; XXX This needs to happen before service activations, so it
-                  ;; has to be here, but this also implicitly assumes that /tmp
-                  ;; and /var/run are on the root partition.
-                  (letrec-syntax ((fail-safe (syntax-rules ()
-                                               ((_ exp rest ...)
-                                                (begin
-                                                  (catch 'system-error
-                                                    (lambda () exp)
-                                                    (const #f))
-                                                  (fail-safe rest ...)))
-                                               ((_)
-                                                #t))))
-                    ;; Ignore I/O errors so the system can boot.
-                    (fail-safe
-                     ;; Remove stale Shadow lock files as they would lead to
-                     ;; failures of 'useradd' & co.
-                     (delete-file "/etc/group.lock")
-                     (delete-file "/etc/passwd.lock")
-                     (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
-
-                     ;; Force file names to be decoded as UTF-8.  See
-                     ;; <https://bugs.gnu.org/26353>.
-                     (setenv "GUIX_LOCPATH"
-                             #+(file-append glibc-utf8-locales "/lib/locale"))
-                     (setlocale LC_CTYPE "en_US.utf8")
-                     (delete-file-recursively "/tmp")
-                     (delete-file-recursively "/var/run")
-
-                     (mkdir "/tmp")
-                     (chmod "/tmp" #o1777)
-                     (mkdir "/var/run")
-                     (chmod "/var/run" #o755)
-                     (delete-file-recursively "/run/udev/watch.old"))))))))
+  "Return a gexp to clean up /tmp and similar places upon boot."
+  (with-imported-modules '((guix build utils))
+    #~(begin
+        (use-modules (guix build utils))
+
+        ;; Clean out /tmp and /var/run.
+        ;;
+        ;; XXX This needs to happen before service activations, so it
+        ;; has to be here, but this also implicitly assumes that /tmp
+        ;; and /var/run are on the root partition.
+        (letrec-syntax ((fail-safe (syntax-rules ()
+                                     ((_ exp rest ...)
+                                      (begin
+                                        (catch 'system-error
+                                          (lambda () exp)
+                                          (const #f))
+                                        (fail-safe rest ...)))
+                                     ((_)
+                                      #t))))
+          ;; Ignore I/O errors so the system can boot.
+          (fail-safe
+           ;; Remove stale Shadow lock files as they would lead to
+           ;; failures of 'useradd' & co.
+           (delete-file "/etc/group.lock")
+           (delete-file "/etc/passwd.lock")
+           (delete-file "/etc/.pwd.lock")         ;from 'lckpwdf'
+
+           ;; Force file names to be decoded as UTF-8.  See
+           ;; <https://bugs.gnu.org/26353>.
+           (setenv "GUIX_LOCPATH"
+                   #+(file-append glibc-utf8-locales "/lib/locale"))
+           (setlocale LC_CTYPE "en_US.utf8")
+           (delete-file-recursively "/tmp")
+           (delete-file-recursively "/var/run")
+
+           (mkdir "/tmp")
+           (chmod "/tmp" #o1777)
+           (mkdir "/var/run")
+           (chmod "/var/run" #o755)
+           (delete-file-recursively "/run/udev/watch.old"))))))
 
 (define cleanup-service-type
   ;; Service that cleans things up in /tmp and similar.
@@ -432,44 +429,39 @@ ACTIVATION-SCRIPT-TYPE."
 
 (define (activation-script gexps)
   "Return the system's activation script, which evaluates GEXPS."
-  (define (service-activations)
-    ;; Return the activation scripts for SERVICES.
-    (mapm %store-monad
-          (cut gexp->file "activate-service" <>)
-          gexps))
-
-  (mlet* %store-monad ((actions (service-activations)))
-    (gexp->file "activate"
-                (with-imported-modules (source-module-closure
-                                        '((gnu build activation)
-                                          (guix build utils)))
-                  #~(begin
-                      (use-modules (gnu build activation)
-                                   (guix build utils))
-
-                      ;; Make sure the user accounting database exists.  If it
-                      ;; does not exist, 'setutxent' does not create it and
-                      ;; thus there is no accounting at all.
-                      (close-port (open-file "/var/run/utmpx" "a0"))
-
-                      ;; Same for 'wtmp', which is populated by mingetty et
-                      ;; al.
-                      (mkdir-p "/var/log")
-                      (close-port (open-file "/var/log/wtmp" "a0"))
-
-                      ;; Set up /run/current-system.  Among other things this
-                      ;; sets up locales, which the activation snippets
-                      ;; executed below may expect.
-                      (activate-current-system)
-
-                      ;; Run the services' activation snippets.
-                      ;; TODO: Use 'load-compiled'.
-                      (for-each primitive-load '#$actions))))))
+  (define actions
+    (map (cut scheme-file "activate-service" <>) gexps))
+
+  (scheme-file "activate"
+               (with-imported-modules (source-module-closure
+                                       '((gnu build activation)
+                                         (guix build utils)))
+                 #~(begin
+                     (use-modules (gnu build activation)
+                                  (guix build utils))
+
+                     ;; Make sure the user accounting database exists.  If it
+                     ;; does not exist, 'setutxent' does not create it and
+                     ;; thus there is no accounting at all.
+                     (close-port (open-file "/var/run/utmpx" "a0"))
+
+                     ;; Same for 'wtmp', which is populated by mingetty et
+                     ;; al.
+                     (mkdir-p "/var/log")
+                     (close-port (open-file "/var/log/wtmp" "a0"))
+
+                     ;; Set up /run/current-system.  Among other things this
+                     ;; sets up locales, which the activation snippets
+                     ;; executed below may expect.
+                     (activate-current-system)
+
+                     ;; Run the services' activation snippets.
+                     ;; TODO: Use 'load-compiled'.
+                     (for-each primitive-load '#$actions)))))
 
 (define (gexps->activation-gexp gexps)
   "Return a gexp that runs the activation script containing GEXPS."
-  (mlet %store-monad ((script (activation-script gexps)))
-    (return #~(primitive-load #$script))))
+  #~(primitive-load #$(activation-script gexps)))
 
 (define (second-argument a b) b)
 
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 000e85e..6ca53fa 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -22,7 +22,6 @@
   #:use-module (guix sets)
   #:use-module (guix gexp)
   #:use-module (guix store)
-  #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix derivations)                 ;imported-modules, etc.
   #:use-module (gnu services)
@@ -66,26 +65,25 @@
 
 
 (define (shepherd-boot-gexp services)
-  (with-monad %store-monad
-    (return #~(begin
-                ;; Keep track of the booted system.
-                (false-if-exception (delete-file "/run/booted-system"))
-                (symlink (readlink "/run/current-system")
-                         "/run/booted-system")
-
-                ;; Close any remaining open file descriptors to be on the safe
-                ;; side.  This must be the very last thing we do, because
-                ;; Guile has internal FDs such as 'sleep_pipe' that need to be
-                ;; alive.
-                (let loop ((fd 3))
-                  (when (< fd 1024)
-                    (false-if-exception (close-fdes fd))
-                    (loop (+ 1 fd))))
-
-                ;; Start shepherd.
-                (execl #$(file-append shepherd "/bin/shepherd")
-                       "shepherd" "--config"
-                       #$(shepherd-configuration-file services))))))
+  #~(begin
+      ;; Keep track of the booted system.
+      (false-if-exception (delete-file "/run/booted-system"))
+      (symlink (readlink "/run/current-system")
+               "/run/booted-system")
+
+      ;; Close any remaining open file descriptors to be on the safe
+      ;; side.  This must be the very last thing we do, because
+      ;; Guile has internal FDs such as 'sleep_pipe' that need to be
+      ;; alive.
+      (let loop ((fd 3))
+        (when (< fd 1024)
+          (false-if-exception (close-fdes fd))
+          (loop (+ 1 fd))))
+
+      ;; Start shepherd.
+      (execl #$(file-append shepherd "/bin/shepherd")
+             "shepherd" "--config"
+             #$(shepherd-configuration-file services))))
 
 (define shepherd-root-service-type
   (service-type
diff --git a/gnu/system.scm b/gnu/system.scm
index 7c51c4d..84eab5f 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -819,7 +819,6 @@ we're running in the final root.  When CONTAINER? is true, 
skip all
 hardware-related operations as necessary when booting a Linux container."
   (let* ((services (operating-system-services os #:container? container?))
          (boot     (fold-services services #:target-type boot-service-type)))
-    ;; BOOT is the script as a monadic value.
     (service-value boot)))
 
 (define (operating-system-user-accounts os)
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index d209066..4c24cf5 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -484,20 +484,19 @@ in a loop.  See <http://bugs.gnu.org/26931>.")
   (simple-operating-system
    (simple-service 'dirty-things
                    boot-service-type
-                   (with-monad %store-monad
-                     (let ((script (plain-file
-                                    "create-utf8-file.sh"
-                                    (string-append
-                                     "echo $0: dirtying /tmp...\n"
-                                     "set -e; set -x\n"
-                                     "touch /witness\n"
-                                     "exec touch /tmp/λαμβδα"))))
-                       (with-imported-modules '((guix build utils))
-                         (return #~(begin
-                                     (setenv "PATH"
-                                             #$(file-append coreutils "/bin"))
-                                     (invoke #$(file-append bash "/bin/sh")
-                                             #$script)))))))))
+                   (let ((script (plain-file
+                                  "create-utf8-file.sh"
+                                  (string-append
+                                   "echo $0: dirtying /tmp...\n"
+                                   "set -e; set -x\n"
+                                   "touch /witness\n"
+                                   "exec touch /tmp/λαμβδα"))))
+                     (with-imported-modules '((guix build utils))
+                       #~(begin
+                           (setenv "PATH"
+                                   #$(file-append coreutils "/bin"))
+                           (invoke #$(file-append bash "/bin/sh")
+                                   #$script)))))))
 
 (define (run-cleanup-test name)
   (define os