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.

gnu/system/dmd.scm

@@ -31,6 +31,7 @@ (define-module (gnu system dmd)
                 #: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 @@ (define-record-type* <service>
   (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 @@ (define syslog.conf
 
      # 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 @@ (define* (static-networking-service store interface ip
   ;; 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 @@ (define config
                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

gnu/system/grub.scm

@@ -21,6 +21,7 @@ (define-module (gnu system grub)
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix records)
+  #:use-module (guix monads)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:export (menu-entry
@@ -42,43 +43,45 @@ (define-record-type* <menu-entry>
                    (default '()))
   (initrd          menu-entry-initrd))
 
-(define* (grub-configuration-file store entries
+(define* (grub-configuration-file entries
                                   #:key (default-entry 1) (timeout 5)
                                   (system (%current-system)))
-  "Return the GRUB configuration file in STORE for ENTRIES, a list of
+  "Return the GRUB configuration file for ENTRIES, a list of
 <menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
-  (define prologue
+  (define (prologue kernel)
     (format #f "
 set default=~a
 set timeout=~a
 search.file ~a~%"
-            default-entry timeout
-            (any (match-lambda
-                  (($ <menu-entry> _ linux)
-                   (let* ((drv (package-derivation store linux system))
-                          (out (derivation->output-path drv)))
-                     (string-append out "/bzImage"))))
-                 entries)))
+            default-entry timeout kernel))
+
+  (define (bzImage)
+    (anym %store-monad
+          (match-lambda
+           (($ <menu-entry> _ linux)
+            (package-file linux "bzImage"
+                          #:system system)))
+          entries))
 
   (define entry->text
     (match-lambda
      (($ <menu-entry> label linux arguments initrd)
-      (let ((linux-drv  (package-derivation store linux system))
-            (initrd-drv (package-derivation store initrd system)))
+      (mlet %store-monad ((linux  (package-file linux "bzImage"
+                                                #:system system))
+                          (initrd (package-file initrd "initrd"
+                                                #:system system)))
         ;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
-        (format #f "menuentry ~s {
-  linux ~a/bzImage ~a
-  initrd ~a/initrd
+        (return (format #f "menuentry ~s {
+  linux ~a ~a
+  initrd ~a
 }~%"
-                label
-                (derivation->output-path linux-drv)
-                (string-join arguments)
-                (derivation->output-path initrd-drv))))))
+                        label
+                        linux (string-join arguments) initrd))))))
 
-  (add-text-to-store store "grub.cfg"
-                     (string-append prologue
-                                    (string-concatenate
-                                     (map entry->text entries)))
-                     '()))
+  (mlet %store-monad ((kernel (bzImage))
+                      (body   (mapm %store-monad entry->text entries)))
+    (text-file "grub.cfg"
+               (string-append (prologue kernel)
+                              (string-concatenate body)))))
 
 ;;; grub.scm ends here

gnu/system/linux.scm

@@ -20,6 +20,7 @@ (define-module (gnu system linux)
   #:use-module (guix store)
   #:use-module (guix records)
   #:use-module (guix derivations)
+  #:use-module (guix monads)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -81,17 +82,20 @@ (define (entry->string type entry)
               (map (cut entry->string "password" <>) password)
               (map (cut entry->string "session" <>) session))))))
 
-(define (pam-services->directory store services)
+(define (pam-services->directory services)
   "Return the derivation to build the configuration directory to be used as
 /etc/pam.d for SERVICES."
-  (let ((names (map pam-service-name services))
-        (files (map (match-lambda
+  (mlet %store-monad
+      ((names -> (map pam-service-name services))
+       (files (mapm %store-monad
+                    (match-lambda
                      ((and service ($ <pam-service> name))
                       (let ((config (pam-service->configuration service)))
-                        (add-text-to-store store
-                                           (string-append name ".pam")
-                                           config '()))))
-                    services)))
+                        (text-file (string-append name ".pam") config))))
+
+                    ;; XXX: Eventually, SERVICES may be a list of monadic
+                    ;; values instead of plain values.
+                    (map return services))))
     (define builder
       '(begin
          (use-modules (ice-9 match))
@@ -104,9 +108,7 @@ (define builder
                      %build-inputs)
            #t)))
 
-    (build-expression->derivation store "pam.d" (%current-system)
-                                  builder
-                                  (zip names files))))
+    (derivation-expression "pam.d" (%current-system) builder (zip names files))))
 
 (define %pam-other-services
   ;; The "other" PAM configuration, which denies everything (see

gnu/system/shadow.scm

@@ -20,6 +20,7 @@ (define-module (gnu system shadow)
   #:use-module (guix store)
   #:use-module (guix records)
   #:use-module (guix packages)
+  #:use-module (guix monads)
   #:use-module ((gnu packages system)
                 #:select (shadow))
   #:use-module (srfi srfi-1)
@@ -72,7 +73,7 @@ (define-record-type* <user-group>
   (id             user-group-id)
   (members        user-group-members (default '())))
 
-(define (group-file store groups)
+(define (group-file groups)
   "Return a /etc/group file for GROUPS, a list of <user-group> objects."
   (define contents
     (let loop ((groups groups)
@@ -87,9 +88,9 @@ (define contents
         (()
          (string-join (reverse result) "\n" 'suffix)))))
 
-  (add-text-to-store store "group" contents))
+  (text-file "group" contents))
 
-(define* (passwd-file store accounts #:key shadow?)
+(define* (passwd-file accounts #:key shadow?)
   "Return a password file for ACCOUNTS, a list of <user-account> objects.  If
 SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd
 file."
@@ -114,28 +115,27 @@ (define contents
         (()
          (string-join (reverse result) "\n" 'suffix)))))
 
-  (add-text-to-store store (if shadow? "shadow" "passwd")
-                     contents '()))
+  (text-file (if shadow? "shadow" "passwd") contents))
 
-(define* (guix-build-accounts store count #:key
+(define* (guix-build-accounts count #:key
                               (first-uid 30001)
                               (gid 30000)
                               (shadow shadow))
   "Return a list of COUNT user accounts for Guix build users, with UIDs
 starting at FIRST-UID, and under GID."
-  (let* ((gid*     gid)
-         (no-login (string-append (package-output store shadow) "/sbin/nologin")))
-    (unfold (cut > <> count)
-            (lambda (n)
-              (user-account
-               (name (format #f "guixbuilder~2,'0d" n))
-               (password "!")
-               (uid (+ first-uid n -1))
-               (gid gid*)
-               (comment (format #f "Guix Build User ~2d" n))
-               (home-directory "/var/empty")
-               (shell no-login)))
-            1+
-            1)))
+  (mlet* %store-monad ((gid* -> gid)
+                       (no-login (package-file shadow "sbin/nologin")))
+    (return (unfold (cut > <> count)
+                    (lambda (n)
+                      (user-account
+                       (name (format #f "guixbuilder~2,'0d" n))
+                       (password "!")
+                       (uid (+ first-uid n -1))
+                       (gid gid*)
+                       (comment (format #f "Guix Build User ~2d" n))
+                       (home-directory "/var/empty")
+                       (shell no-login)))
+                    1+
+                    1))))
 
 ;;; shadow.scm ends here