From 023f391c7860d21aee9e9b3e601d7a81bb5d128d Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 10 May 2014 23:33:52 +0200
Subject: services: Add 'file-system-service'.

* gnu/services/base.scm (file-system-service): New procedure.
  (user-processes-service): Add 'requirements' parameter.
* gnu/services/dmd.scm (dmd-configuration-file): Use (guix build
  linux-initrd).
* guix/build/linux-initrd.scm (guix): Export 'check-file-system'.
* gnu/system.scm (file-union): New procedure.
  (essential-services): Use it.  Add that to the returned list.
---
 gnu/services/base.scm | 30 ++++++++++++++++++++++++++++--
 gnu/services/dmd.scm  |  8 ++++++--
 2 files changed, 34 insertions(+), 4 deletions(-)

(limited to 'gnu/services')

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index e0f2888ee0..6431a3aaba 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -30,6 +30,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 format)
   #:export (root-file-system-service
+            file-system-service
             user-processes-service
             host-name-service
             mingetty-service
@@ -87,19 +88,44 @@ This service must be the root of the service dependency graph so that its
                      #f)))))
       (respawn? #f)))))
 
-(define* (user-processes-service #:key (grace-delay 2))
+(define* (file-system-service device target type
+                              #:key (check? #t) options)
+  "Return a service that mounts DEVICE on TARGET as a file system TYPE with
+OPTIONS.  When CHECK? is true, check the file system before mounting it."
+  (with-monad %store-monad
+    (return
+     (service
+      (provision (list (symbol-append 'file-system- (string->symbol target))))
+      (requirement '(root-file-system))
+      (documentation "Check, mount, and unmount the given file system.")
+      (start #~(lambda args
+                 #$(if check?
+                       #~(check-file-system #$device #$type)
+                       #~#t)
+                 (mount #$device #$target #$type 0 #$options)
+                 #t))
+      (stop #~(lambda args
+                ;; Normally there are no processes left at this point, so
+                ;; TARGET can be safely unmounted.
+                (umount #$target)
+                #f))))))
+
+(define* (user-processes-service requirements #:key (grace-delay 2))
   "Return the service that is responsible for terminating all the processes so
 that the root file system can be re-mounted read-only, just before
 rebooting/halting.  Processes still running GRACE-DELAY seconds after SIGTERM
 has been sent are terminated with SIGKILL.
 
+The returned service will depend on 'root-file-system' and on all the services
+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 '(root-file-system))
+             (requirement (cons 'root-file-system requirements))
              (start #~(const #t))
              (stop #~(lambda _
                        ;; When this happens, all the processes have been
diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index 8d4c483cc4..0d17285890 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -34,7 +34,9 @@
   "Return the dmd configuration file for SERVICES."
   (define modules
     ;; Extra modules visible to dmd.conf.
-    '((guix build syscalls)))
+    '((guix build syscalls)
+      (guix build linux-initrd)
+      (guix build utils)))
 
   (mlet %store-monad ((modules  (imported-modules modules))
                       (compiled (compiled-modules modules)))
@@ -46,7 +48,9 @@
                   (cons #$compiled %load-compiled-path)))
 
           (use-modules (ice-9 ftw)
-                       (guix build syscalls))
+                       (guix build syscalls)
+                       ((guix build linux-initrd)
+                        #:select (check-file-system)))
 
           (register-services
            #$@(map (lambda (service)
-- 
cgit v1.2.3