gnu: vm: Rewrite helper functions as monadic functions.

* gnu/system/dmd.scm (host-name-service, nscd-service, mingetty-service,
  syslog-service, guix-service, static-networking-service): Rewrite as
  monadic functions.
  (dmd-configuration-file): Use 'text-file' instead of
  'add-text-to-store'.
* gnu/system/grub.scm (grub-configuration-file): Rewrite as a monadic
  function.
* gnu/system/linux.scm (pam-services->directory): Likewise.
* gnu/system/shadow.scm (group-file, passwd-file, guix-build-accounts):
  Likewise.
* gnu/system/vm.scm (expression->derivation-in-linux-vm, qemu-image,
  union, system-qemu-image): Likewise.

1 files changed, 84 insertions, 88 deletions

diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm
index 4d3b4b31f0..946b6a7937 100644
--- a/gnu/system/dmd.scm
+++ b/gnu/system/dmd.scm
@@ -31,6 +31,7 @@
                 #:select (net-tools))
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (guix monads)
   #:export (service?
             service
             service-provision
@@ -69,53 +70,51 @@
   (inputs        service-inputs                   ; list of inputs
                  (default '())))
 
-(define (host-name-service store name)
+(define (host-name-service name)
   "Return a service that sets the host name to NAME."
-  (service
-   (provision '(host-name))
-   (start `(lambda _
-             (sethostname ,name)))
-   (respawn? #f)))
-
-(define (mingetty-service store tty)
+  (with-monad %store-monad
+    (return (service
+             (provision '(host-name))
+             (start `(lambda _
+                       (sethostname ,name)))
+             (respawn? #f)))))
+
+(define (mingetty-service tty)
   "Return a service to run mingetty on TTY."
-  (let* ((mingetty-drv (package-derivation store mingetty))
-         (mingetty-bin (string-append (derivation->output-path mingetty-drv)
-                                      "/sbin/mingetty")))
-    (service
-     (provision (list (symbol-append 'term- (string->symbol tty))))
+  (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")))
+    (return
+     (service
+      (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.
-     (requirement '(host-name))
+      ;; Since the login prompt shows the host name, wait for the 'host-name'
+      ;; service to be done.
+      (requirement '(host-name))
 
-     (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
-     (inputs `(("mingetty" ,mingetty))))))
+      (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
+      (inputs `(("mingetty" ,mingetty)))))))
 
-(define* (nscd-service store
-                       #:key (glibc glibc-final))
+(define* (nscd-service #:key (glibc glibc-final))
   "Return a service that runs libc's name service cache daemon (nscd)."
-  (let ((nscd (string-append (package-output store glibc) "/sbin/nscd")))
-    (service
-     (provision '(nscd))
-     (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"))
-
-     ;; XXX: Local copy of 'make-kill-destructor' because the one upstream
-     ;; uses the broken 'opt-lambda' macro.
-     (stop  `(lambda* (#:optional (signal SIGTERM))
-               (lambda (pid . args)
-                 (kill pid signal)
-                 #f)))
-
-     (respawn? #f)
-     (inputs `(("glibc" ,glibc))))))
-
-(define (syslog-service store)
+  (mlet %store-monad ((nscd (package-file glibc "sbin/nscd")))
+    (return (service
+             (provision '(nscd))
+             (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"))
+
+             ;; XXX: Local copy of 'make-kill-destructor' because the one upstream
+             ;; uses the broken 'opt-lambda' macro.
+             (stop  `(lambda* (#:optional (signal SIGTERM))
+                       (lambda (pid . args)
+                         (kill pid signal)
+                         #f)))
+
+             (respawn? #f)
+             (inputs `(("glibc" ,glibc)))))))
+
+(define (syslog-service)
   "Return a service that runs 'syslogd' with reasonable default settings."
 
-  (define syslog.conf
-    ;; Snippet adapted from the GNU inetutils manual.
-    (add-text-to-store store "syslog.conf" "
+  ;; Snippet adapted from the GNU inetutils manual.
+  (define contents "
      # Log all kernel messages, authentication messages of
      # level notice or higher and anything of level err or
      # higher to the console.
@@ -134,31 +133,30 @@
 
      # Log all the mail messages in one place.
      mail.*                                  /var/log/maillog
-"))
-
-  (let* ((inetutils-drv (package-derivation store inetutils))
-         (syslogd       (string-append (derivation->output-path inetutils-drv)
-                                       "/libexec/syslogd")))
-    (service
-     (provision '(syslogd))
-     (start `(make-forkexec-constructor ,syslogd
-                                        "--rcfile" ,syslog.conf))
-     (inputs `(("inetutils" ,inetutils)
-               ("syslog.conf" ,syslog.conf))))))
-
-(define* (guix-service store #:key (guix guix) (builder-group "guixbuild"))
+")
+
+  (mlet %store-monad
+      ((syslog.conf (text-file "syslog.conf" contents))
+       (syslogd     (package-file inetutils "libexec/syslogd")))
+    (return
+     (service
+      (provision '(syslogd))
+      (start `(make-forkexec-constructor ,syslogd
+                                         "--rcfile" ,syslog.conf))
+      (inputs `(("inetutils" ,inetutils)
+                ("syslog.conf" ,syslog.conf)))))))
+
+(define* (guix-service #:key (guix guix) (builder-group "guixbuild"))
   "Return a service that runs the build daemon from GUIX."
-  (let* ((drv    (package-derivation store guix))
-         (daemon (string-append (derivation->output-path drv)
-                                "/bin/guix-daemon")))
-    (service
-     (provision '(guix-daemon))
-     (start `(make-forkexec-constructor ,daemon
-                                        "--build-users-group"
-                                        ,builder-group))
-     (inputs `(("guix" ,guix))))))
-
-(define* (static-networking-service store interface ip
+  (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")))
+    (return (service
+             (provision '(guix-daemon))
+             (start `(make-forkexec-constructor ,daemon
+                                                "--build-users-group"
+                                                ,builder-group))
+             (inputs `(("guix" ,guix)))))))
+
+(define* (static-networking-service interface ip
                                     #:key
                                     gateway
                                     (inetutils inetutils)
@@ -169,31 +167,30 @@ true, it must be a string specifying the default network gateway."
   ;; TODO: Eventually we should do this using Guile's networking procedures,
   ;; like 'configure-qemu-networking' does, but the patch that does this is
   ;; not yet in stock Guile.
-  (let ((ifconfig (string-append (package-output store inetutils)
-                                 "/bin/ifconfig"))
-        (route    (string-append (package-output store net-tools)
-                                 "/sbin/route")))
-    (service
-     (provision '(networking))
-     (start `(lambda _
-               (and (zero? (system* ,ifconfig ,interface ,ip "up"))
-                    ,(if gateway
-                         `(begin
-                            (sleep 3)             ; XXX
-                            (zero? (system* ,route "add" "-net" "default"
-                                            "gw" ,gateway)))
-                         #t))))
-     (stop  `(lambda _
-               (system* ,ifconfig ,interface "down")
-               (system* ,route "del" "-net" "default")))
-     (respawn? #f)
-     (inputs `(("inetutils" ,inetutils)
-               ,@(if gateway
-                     `(("net-tools" ,net-tools))
-                     '()))))))
+  (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig"))
+                      (route    (package-file net-tools "sbin/route")))
+    (return
+     (service
+      (provision '(networking))
+      (start `(lambda _
+                (and (zero? (system* ,ifconfig ,interface ,ip "up"))
+                     ,(if gateway
+                          `(begin
+                             (sleep 3)            ; XXX
+                             (zero? (system* ,route "add" "-net" "default"
+                                             "gw" ,gateway)))
+                          #t))))
+      (stop  `(lambda _
+                (system* ,ifconfig ,interface "down")
+                (system* ,route "del" "-net" "default")))
+      (respawn? #f)
+      (inputs `(("inetutils" ,inetutils)
+                ,@(if gateway
+                      `(("net-tools" ,net-tools))
+                      '())))))))
 
 
-(define (dmd-configuration-file store services)
+(define (dmd-configuration-file services)
   "Return the dmd configuration file for SERVICES."
   (define config
     `(begin
@@ -209,7 +206,6 @@ true, it must be a string specifying the default network gateway."
                services))
        (for-each start ',(append-map service-provision services))))
 
-  (add-text-to-store store "dmd.conf"
-                     (object->string config)))
+  (text-file "dmd.conf" (object->string config)))
 
 ;;; dmd.scm ends here