system: Mapped devices needed for boot do not yield Shepherd services.

Fixes <https://bugs.gnu.org/31889>.
Reported by Taylan Kammer <taylanbayirli@gmail.com>.

* gnu/system.scm (non-boot-file-system-service)[mapped-devices-for-boot]:
New variable.
Remove dependencies of FS that are members of MAPPED-DEVICES-FOR-BOOT.
(mapped-device-user): Rename to...
(mapped-device-users): ... this.  Use 'filter' instead of 'find'.
(operating-system-user-mapped-devices)
(operating-system-boot-mapped-devices): Use 'any
file-system-needed-for-boot?' instead of looking at the first user.
* tests/system.scm ("non-boot-file-system-service"): New test.

2 files changed, 42 insertions, 15 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index 84eab5f84f..e4a57475a9 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -359,6 +359,9 @@ marked as 'needed-for-boot'."
     (remove file-system-needed-for-boot?
             (operating-system-file-systems os)))
 
+  (define mapped-devices-for-boot
+    (operating-system-boot-mapped-devices os))
+
   (define (device-mappings fs)
     (let ((device (file-system-device fs)))
       (if (string? device)                        ;title is 'device
@@ -374,21 +377,23 @@ marked as 'needed-for-boot'."
     (file-system
       (inherit fs)
       (dependencies
-       (delete-duplicates (append (device-mappings fs)
-                                  (file-system-dependencies fs))
-                          eq?))))
+       (delete-duplicates
+        (remove (cut member <> mapped-devices-for-boot)
+                (append (device-mappings fs)
+                        (file-system-dependencies fs)))
+        eq?))))
 
   (service file-system-service-type
            (map add-dependencies file-systems)))
 
-(define (mapped-device-user device file-systems)
-  "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
+(define (mapped-device-users device file-systems)
+  "Return the subset of FILE-SYSTEMS that use DEVICE."
   (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
-    (find (lambda (fs)
-            (or (member device (file-system-dependencies fs))
-                (and (string? (file-system-device fs))
-                     (string=? (file-system-device fs) target))))
-          file-systems)))
+    (filter (lambda (fs)
+              (or (member device (file-system-dependencies fs))
+                  (and (string? (file-system-device fs))
+                       (string=? (file-system-device fs) target))))
+            file-systems)))
 
 (define (operating-system-user-mapped-devices os)
   "Return the subset of mapped devices that can be installed in
@@ -396,9 +401,8 @@ user-land--i.e., those not needed during boot."
   (let ((devices      (operating-system-mapped-devices os))
         (file-systems (operating-system-file-systems os)))
    (filter (lambda (md)
-             (let ((user (mapped-device-user md file-systems)))
-               (or (not user)
-                   (not (file-system-needed-for-boot? user)))))
+             (let ((users (mapped-device-users md file-systems)))
+               (not (any file-system-needed-for-boot? users))))
            devices)))
 
 (define (operating-system-boot-mapped-devices os)
@@ -407,8 +411,8 @@ from the initrd."
   (let ((devices      (operating-system-mapped-devices os))
         (file-systems (operating-system-file-systems os)))
    (filter (lambda (md)
-             (let ((user (mapped-device-user md file-systems)))
-               (and user (file-system-needed-for-boot? user))))
+             (let ((users (mapped-device-users md file-systems)))
+               (any file-system-needed-for-boot? users)))
            devices)))
 
 (define (device-mapping-services os)
diff --git a/tests/system.scm b/tests/system.scm
index 7d55da7174..9416b950e6 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -19,6 +19,7 @@
 
 (define-module (test-system)
   #:use-module (gnu)
+  #:use-module ((gnu services) #:select (service-value))
   #:use-module (guix store)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64))
@@ -117,4 +118,26 @@
                            (type "ext4"))
                          %base-file-systems)))))
 
+(test-equal "non-boot-file-system-service"
+  '()
+
+  ;; Make sure that mapped devices with at least one needed-for-boot user are
+  ;; handled exclusively from the initrd.  See <https://bugs.gnu.org/31889>.
+  (append-map file-system-dependencies
+              (service-value
+               ((@@ (gnu system) non-boot-file-system-service)
+                (operating-system
+                  (inherit %os-with-mapped-device)
+                  (file-systems
+                   (list (file-system
+                           (mount-point "/foo/bar")
+                           (device "qux:baz")
+                           (type "none")
+                           (dependencies (list %luks-device)))
+                         (file-system
+                           (device (file-system-label "my-root"))
+                           (mount-point "/")
+                           (type "ext4")
+                           (dependencies (list %luks-device))))))))))
+
 (test-end)