diff options
| -rw-r--r-- | gnu/services/base.scm | 28 | ||||
| -rw-r--r-- | gnu/system.scm | 6 | ||||
| -rw-r--r-- | gnu/system/install.scm | 4 |
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)))))))) |