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