services: Make a single extensible 'file-systems' service.
Previously we would create one 'file-system-service-type' instead per file system. Now, we create only one instance for all the file systems. * gnu/services/base.scm (fstab-service-type)[compose]: Change to CONCATENATE. (file-system-shepherd-service): Change to return either one <shepherd-service> or #f. (file-system-service-type): Pluralize 'name'. Adjust SHEPHERD-ROOT-SERVICE-TYPE extension to above changes. Add 'compose' and 'extend'. (file-system-service): Remove. * gnu/system.scm (other-file-system-services): Rename to... (non-boot-file-system-service): ... this. Change to return a single FILE-SYSTEM-SERVICE-TYPE instance. (essential-services): Adjust accordingly.
This commit is contained in:
		
							parent
							
								
									9af4983266
								
							
						
					
					
						commit
						aa1145df8d
					
				
					 2 changed files with 24 additions and 26 deletions
				
			
		| 
						 | 
					@ -49,7 +49,7 @@
 | 
				
			||||||
  #:use-module (ice-9 format)
 | 
					  #:use-module (ice-9 format)
 | 
				
			||||||
  #:export (fstab-service-type
 | 
					  #:export (fstab-service-type
 | 
				
			||||||
            root-file-system-service
 | 
					            root-file-system-service
 | 
				
			||||||
            file-system-service
 | 
					            file-system-service-type
 | 
				
			||||||
            user-unmount-service
 | 
					            user-unmount-service
 | 
				
			||||||
            swap-service
 | 
					            swap-service
 | 
				
			||||||
            user-processes-service
 | 
					            user-processes-service
 | 
				
			||||||
| 
						 | 
					@ -164,7 +164,7 @@
 | 
				
			||||||
                (extensions
 | 
					                (extensions
 | 
				
			||||||
                 (list (service-extension etc-service-type
 | 
					                 (list (service-extension etc-service-type
 | 
				
			||||||
                                          file-systems->fstab)))
 | 
					                                          file-systems->fstab)))
 | 
				
			||||||
                (compose identity)
 | 
					                (compose concatenate)
 | 
				
			||||||
                (extend append)))
 | 
					                (extend append)))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define %root-file-system-shepherd-service
 | 
					(define %root-file-system-shepherd-service
 | 
				
			||||||
| 
						 | 
					@ -230,7 +230,8 @@ FILE-SYSTEM."
 | 
				
			||||||
     (file-system->shepherd-service-name fs))))
 | 
					     (file-system->shepherd-service-name fs))))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (file-system-shepherd-service file-system)
 | 
					(define (file-system-shepherd-service file-system)
 | 
				
			||||||
  "Return a list containing the shepherd service for @var{file-system}."
 | 
					  "Return the shepherd service for @var{file-system}, or @code{#f} if
 | 
				
			||||||
 | 
					@var{file-system} is not auto-mounted upon boot."
 | 
				
			||||||
  (let ((target  (file-system-mount-point file-system))
 | 
					  (let ((target  (file-system-mount-point file-system))
 | 
				
			||||||
        (device  (file-system-device file-system))
 | 
					        (device  (file-system-device file-system))
 | 
				
			||||||
        (type    (file-system-type file-system))
 | 
					        (type    (file-system-type file-system))
 | 
				
			||||||
| 
						 | 
					@ -238,10 +239,9 @@ FILE-SYSTEM."
 | 
				
			||||||
        (check?  (file-system-check? file-system))
 | 
					        (check?  (file-system-check? file-system))
 | 
				
			||||||
        (create? (file-system-create-mount-point? file-system))
 | 
					        (create? (file-system-create-mount-point? file-system))
 | 
				
			||||||
        (dependencies (file-system-dependencies file-system)))
 | 
					        (dependencies (file-system-dependencies file-system)))
 | 
				
			||||||
    (if (file-system-mount? file-system)
 | 
					    (and (file-system-mount? file-system)
 | 
				
			||||||
         (with-imported-modules '((gnu build file-systems)
 | 
					         (with-imported-modules '((gnu build file-systems)
 | 
				
			||||||
                                  (guix build bournish))
 | 
					                                  (guix build bournish))
 | 
				
			||||||
          (list
 | 
					 | 
				
			||||||
           (shepherd-service
 | 
					           (shepherd-service
 | 
				
			||||||
            (provision (list (file-system->shepherd-service-name file-system)))
 | 
					            (provision (list (file-system->shepherd-service-name file-system)))
 | 
				
			||||||
            (requirement `(root-file-system
 | 
					            (requirement `(root-file-system
 | 
				
			||||||
| 
						 | 
					@ -290,23 +290,19 @@ FILE-SYSTEM."
 | 
				
			||||||
            ;; We need an additional module.
 | 
					            ;; We need an additional module.
 | 
				
			||||||
            (modules `(((gnu build file-systems)
 | 
					            (modules `(((gnu build file-systems)
 | 
				
			||||||
                        #:select (check-file-system canonicalize-device-spec))
 | 
					                        #:select (check-file-system canonicalize-device-spec))
 | 
				
			||||||
                       ,@%default-modules)))))
 | 
					                       ,@%default-modules)))))))
 | 
				
			||||||
        '())))
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define file-system-service-type
 | 
					(define file-system-service-type
 | 
				
			||||||
  ;; TODO(?): Make this an extensible service that takes <file-system> objects
 | 
					  (service-type (name 'file-systems)
 | 
				
			||||||
  ;; and returns a list of <shepherd-service>.
 | 
					 | 
				
			||||||
  (service-type (name 'file-system)
 | 
					 | 
				
			||||||
                (extensions
 | 
					                (extensions
 | 
				
			||||||
                 (list (service-extension shepherd-root-service-type
 | 
					                 (list (service-extension shepherd-root-service-type
 | 
				
			||||||
                                          file-system-shepherd-service)
 | 
					                                          (lambda (file-systems)
 | 
				
			||||||
 | 
					                                            (filter-map file-system-shepherd-service
 | 
				
			||||||
 | 
					                                                        file-systems)))
 | 
				
			||||||
                       (service-extension fstab-service-type
 | 
					                       (service-extension fstab-service-type
 | 
				
			||||||
                                          identity)))))
 | 
					                                          identity)))
 | 
				
			||||||
 | 
					                (compose concatenate)
 | 
				
			||||||
(define* (file-system-service file-system)
 | 
					                (extend append)))
 | 
				
			||||||
  "Return a service that mounts @var{file-system}, a @code{<file-system>}
 | 
					 | 
				
			||||||
object."
 | 
					 | 
				
			||||||
  (service file-system-service-type file-system))
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define user-unmount-service-type
 | 
					(define user-unmount-service-type
 | 
				
			||||||
  (shepherd-service-type
 | 
					  (shepherd-service-type
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -178,9 +178,9 @@
 | 
				
			||||||
;;; Services.
 | 
					;;; Services.
 | 
				
			||||||
;;;
 | 
					;;;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (other-file-system-services os)
 | 
					(define (non-boot-file-system-service os)
 | 
				
			||||||
  "Return file system services for the file systems of OS that are not marked
 | 
					  "Return the file system service for the file systems of OS that are not
 | 
				
			||||||
as 'needed-for-boot'."
 | 
					marked as 'needed-for-boot'."
 | 
				
			||||||
  (define file-systems
 | 
					  (define file-systems
 | 
				
			||||||
    (remove file-system-needed-for-boot?
 | 
					    (remove file-system-needed-for-boot?
 | 
				
			||||||
            (operating-system-file-systems os)))
 | 
					            (operating-system-file-systems os)))
 | 
				
			||||||
| 
						 | 
					@ -204,7 +204,8 @@ as 'needed-for-boot'."
 | 
				
			||||||
                                  (file-system-dependencies fs))
 | 
					                                  (file-system-dependencies fs))
 | 
				
			||||||
                          eq?))))
 | 
					                          eq?))))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  (map (compose file-system-service add-dependencies) file-systems))
 | 
					  (service file-system-service-type
 | 
				
			||||||
 | 
					           (map add-dependencies file-systems)))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (mapped-device-user device file-systems)
 | 
					(define (mapped-device-user device file-systems)
 | 
				
			||||||
  "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
 | 
					  "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
 | 
				
			||||||
| 
						 | 
					@ -270,11 +271,11 @@ a container or that of a \"bare metal\" system."
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  (let* ((mappings  (device-mapping-services os))
 | 
					  (let* ((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  (non-boot-file-system-service os))
 | 
				
			||||||
         (unmount   (user-unmount-service known-fs))
 | 
					         (unmount   (user-unmount-service known-fs))
 | 
				
			||||||
         (swaps     (swap-services os))
 | 
					         (swaps     (swap-services os))
 | 
				
			||||||
         (procs     (user-processes-service
 | 
					         (procs     (user-processes-service
 | 
				
			||||||
                     (map service-parameters other-fs)))
 | 
					                     (service-parameters other-fs)))
 | 
				
			||||||
         (host-name (host-name-service (operating-system-host-name os)))
 | 
					         (host-name (host-name-service (operating-system-host-name os)))
 | 
				
			||||||
         (entries   (operating-system-directory-base-entries
 | 
					         (entries   (operating-system-directory-base-entries
 | 
				
			||||||
                     os #:container? container?)))
 | 
					                     os #:container? container?)))
 | 
				
			||||||
| 
						 | 
					@ -302,7 +303,8 @@ a container or that of a \"bare metal\" system."
 | 
				
			||||||
                    (operating-system-setuid-programs os))
 | 
					                    (operating-system-setuid-programs os))
 | 
				
			||||||
           (service profile-service-type
 | 
					           (service profile-service-type
 | 
				
			||||||
                    (operating-system-packages os))
 | 
					                    (operating-system-packages os))
 | 
				
			||||||
           (append other-fs mappings swaps
 | 
					           other-fs
 | 
				
			||||||
 | 
					           (append mappings swaps
 | 
				
			||||||
 | 
					
 | 
				
			||||||
                   ;; Add the firmware service, unless we are building for a
 | 
					                   ;; Add the firmware service, unless we are building for a
 | 
				
			||||||
                   ;; container.
 | 
					                   ;; container.
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Reference in a new issue