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
|
@ -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.
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))))))))
|
||||
|
||||
|
|
Loading…
Reference in New Issue