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.
This commit is contained in:
parent
ccea821bef
commit
d6e2a622c4
3 changed files with 36 additions and 2 deletions
|
|
@ -38,6 +38,7 @@
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
#:export (root-file-system-service
|
#:export (root-file-system-service
|
||||||
file-system-service
|
file-system-service
|
||||||
|
user-unmount-service
|
||||||
device-mapping-service
|
device-mapping-service
|
||||||
swap-service
|
swap-service
|
||||||
user-processes-service
|
user-processes-service
|
||||||
|
|
@ -145,6 +146,33 @@ names such as device-mapping services."
|
||||||
(umount #$target)
|
(umount #$target)
|
||||||
#f))))))
|
#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
|
(define %do-not-kill-file
|
||||||
;; Name of the file listing PIDs of processes that must survive when halting
|
;; Name of the file listing PIDs of processes that must survive when halting
|
||||||
;; the system. Typical example is user-space file systems.
|
;; the system. Typical example is user-space file systems.
|
||||||
|
|
|
||||||
|
|
@ -269,16 +269,20 @@ from the initrd."
|
||||||
"Return the list of essential services for OS. These are special services
|
"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
|
that implement part of what's declared in OS are responsible for low-level
|
||||||
bookkeeping."
|
bookkeeping."
|
||||||
|
(define known-fs
|
||||||
|
(map file-system-mount-point (operating-system-file-systems os)))
|
||||||
|
|
||||||
(mlet* %store-monad ((mappings (device-mapping-services os))
|
(mlet* %store-monad ((mappings (device-mapping-services os))
|
||||||
(root-fs (root-file-system-service))
|
(root-fs (root-file-system-service))
|
||||||
(other-fs (other-file-system-services os))
|
(other-fs (other-file-system-services os))
|
||||||
|
(unmount (user-unmount-service known-fs))
|
||||||
(swaps (swap-services os))
|
(swaps (swap-services os))
|
||||||
(procs (user-processes-service
|
(procs (user-processes-service
|
||||||
(map (compose first service-provision)
|
(map (compose first service-provision)
|
||||||
other-fs)))
|
other-fs)))
|
||||||
(host-name (host-name-service
|
(host-name (host-name-service
|
||||||
(operating-system-host-name os))))
|
(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)))))
|
(append other-fs mappings swaps)))))
|
||||||
|
|
||||||
(define (operating-system-services os)
|
(define (operating-system-services os)
|
||||||
|
|
|
||||||
|
|
@ -112,7 +112,9 @@ the given target.")
|
||||||
(stop #~(lambda (target)
|
(stop #~(lambda (target)
|
||||||
;; Delete the temporary directory, but leave everything
|
;; Delete the temporary directory, but leave everything
|
||||||
;; mounted as there may still be processes using it
|
;; 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
|
(delete-file-recursively
|
||||||
(string-append target #$%backing-directory))))))))
|
(string-append target #$%backing-directory))))))))
|
||||||
|
|
||||||
|
|
|
||||||
Reference in a new issue