From d6e2a622c49184390d362abf97ca1c56498cfd6a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 10 Nov 2014 22:25:39 +0100
Subject: services: Add 'user-unmount-service' as an essential service.

* gnu/services/base.scm (user-unmount-service): New procedure.
* gnu/system.scm (essential-services): Use it.
* gnu/system/install.scm (cow-store-service): Mention it in comment.
---
 gnu/services/base.scm | 28 ++++++++++++++++++++++++++++
 1 file changed, 28 insertions(+)

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

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index abf8ae99ac..0c45d54d17 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -38,6 +38,7 @@
   #:use-module (ice-9 format)
   #:export (root-file-system-service
             file-system-service
+            user-unmount-service
             device-mapping-service
             swap-service
             user-processes-service
@@ -145,6 +146,33 @@ names such as device-mapping services."
                 (umount #$target)
                 #f))))))
 
+(define (user-unmount-service known-mount-points)
+  "Return a service whose sole purpose is to unmount file systems not listed
+in KNOWN-MOUNT-POINTS when it is stopped."
+  (with-monad %store-monad
+    (return
+     (service
+      (documentation "Unmount manually-mounted file systems.")
+      (provision '(user-unmount))
+      (start #~(const #t))
+      (stop #~(lambda args
+                (define (known? mount-point)
+                  (member mount-point
+                          (cons* "/proc" "/sys"
+                                 '#$known-mount-points)))
+
+                (for-each (lambda (mount-point)
+                            (format #t "unmounting '~a'...~%" mount-point)
+                            (catch 'system-error
+                              (lambda ()
+                                (umount mount-point))
+                              (lambda args
+                                (let ((errno (system-error-errno args)))
+                                  (format #t "failed to unmount '~a': ~a~%"
+                                          mount-point (strerror errno))))))
+                          (filter (negate known?) (mount-points)))
+                #f))))))
+
 (define %do-not-kill-file
   ;; Name of the file listing PIDs of processes that must survive when halting
   ;; the system.  Typical example is user-space file systems.
-- 
cgit v1.2.3