summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-11-10 22:25:39 +0100
committerLudovic Courtès <ludo@gnu.org>2014-11-10 22:42:14 +0100
commitd6e2a622c49184390d362abf97ca1c56498cfd6a (patch)
tree83543c98a446ad7d67eac35952542af4b6ab1b1f /gnu
parentccea821befc96a2c5e0c64b1a18eef0f31abe0a7 (diff)
downloadpatches-d6e2a622c49184390d362abf97ca1c56498cfd6a.tar
patches-d6e2a622c49184390d362abf97ca1c56498cfd6a.tar.gz
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.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/services/base.scm28
-rw-r--r--gnu/system.scm6
-rw-r--r--gnu/system/install.scm4
3 files changed, 36 insertions, 2 deletions
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.
diff --git a/gnu/system.scm b/gnu/system.scm
index 4140272a3c..57d71e5158 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -269,16 +269,20 @@ from the initrd."
"Return the list of essential services for OS. These are special services
that implement part of what's declared in OS are responsible for low-level
bookkeeping."
+ (define known-fs
+ (map file-system-mount-point (operating-system-file-systems os)))
+
(mlet* %store-monad ((mappings (device-mapping-services os))
(root-fs (root-file-system-service))
(other-fs (other-file-system-services os))
+ (unmount (user-unmount-service known-fs))
(swaps (swap-services os))
(procs (user-processes-service
(map (compose first service-provision)
other-fs)))
(host-name (host-name-service
(operating-system-host-name os))))
- (return (cons* host-name procs root-fs
+ (return (cons* host-name procs root-fs unmount
(append other-fs mappings swaps)))))
(define (operating-system-services os)
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 12470d16c9..6b3aa6cbf2 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -112,7 +112,9 @@ the given target.")
(stop #~(lambda (target)
;; Delete the temporary directory, but leave everything
;; mounted as there may still be processes using it
- ;; since 'user-processes' doesn't depend on us.
+ ;; since 'user-processes' doesn't depend on us. The
+ ;; 'user-unmount' service will unmount TARGET
+ ;; eventually.
(delete-file-recursively
(string-append target #$%backing-directory))))))))