From 615a89e3101b1a512008a3ca3239035674c7d098 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 27 Feb 2018 11:16:37 +0100
Subject: linux-initrd: Separate file system module logic.

* gnu/system/linux-initrd.scm (vhash, lookup-procedure): New macros.
(file-system-type-modules, file-system-modules): New procedures.
(base-initrd)[cifs-modules, virtio-9p-modules]: Remove.
[file-system-type-predicate]: Remove.
Use 'file-system-modules' instead of 'find' +
'file-system-type-predicate'.
---
 gnu/system/linux-initrd.scm | 60 +++++++++++++++++++++++++++------------------
 1 file changed, 36 insertions(+), 24 deletions(-)

(limited to 'gnu/system/linux-initrd.scm')

diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 330438bce4..830445ac83 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -39,6 +39,7 @@
   #:use-module (gnu system mapped-devices)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (expression->initrd
@@ -242,6 +243,40 @@ FILE-SYSTEMS."
           (list btrfs-progs/static)
           '())))
 
+(define-syntax vhash                              ;TODO: factorize
+  (syntax-rules (=>)
+    "Build a vhash with the given key/value mappings."
+    ((_)
+     vlist-null)
+    ((_ (key others ... => value) rest ...)
+     (vhash-cons key value
+                 (vhash (others ... => value) rest ...)))
+    ((_ (=> value) rest ...)
+     (vhash rest ...))))
+
+(define-syntax lookup-procedure
+  (syntax-rules (else)
+    "Return a procedure that lookups keys in the given dictionary."
+    ((_ mapping ... (else default))
+     (let ((table (vhash mapping ...)))
+       (lambda (key)
+         (match (vhash-assoc key table)
+           (#f    default)
+           (value value)))))))
+
+(define file-system-type-modules
+  ;; Given a file system type, return the list of modules it needs.
+  (lookup-procedure ("cifs" => '("md4" "ecb" "cifs"))
+                    ("9p" => '("9p" "9pnet_virtio"))
+                    ("btrfs" => '("btrfs"))
+                    ("iso9660" => '("isofs"))
+                    (else '())))
+
+(define (file-system-modules file-systems)
+  "Return the list of Linux modules needed to mount FILE-SYSTEMS."
+  (append-map (compose file-system-type-modules file-system-type)
+              file-systems))
+
 (define* (base-initrd file-systems
                       #:key
                       (linux linux-libre)
@@ -272,18 +307,6 @@ loaded at boot time in the order in which they appear."
     '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
       "virtio_console"))
 
-  (define cifs-modules
-    ;; Modules needed to mount CIFS file systems.
-    '("md4" "ecb" "cifs"))
-
-  (define virtio-9p-modules
-    ;; Modules for the 9p paravirtualized file system.
-    '("9p" "9pnet_virtio"))
-
-  (define (file-system-type-predicate type)
-    (lambda (fs)
-      (string=? (file-system-type fs) type)))
-
   (define linux-modules
     ;; Modules added to the initrd and loaded from the initrd.
     `("ahci"                                  ;for SATA controllers
@@ -298,18 +321,7 @@ loaded at boot time in the order in which they appear."
       ,@(if (or virtio? qemu-networking?)
             virtio-modules
             '())
-      ,@(if (find (file-system-type-predicate "cifs") file-systems)
-            cifs-modules
-            '())
-      ,@(if (find (file-system-type-predicate "9p") file-systems)
-            virtio-9p-modules
-            '())
-      ,@(if (find (file-system-type-predicate "btrfs") file-systems)
-            '("btrfs")
-            '())
-      ,@(if (find (file-system-type-predicate "iso9660") file-systems)
-            '("isofs")
-            '())
+      ,@(file-system-modules file-systems)
       ,@(if volatile-root?
             '("overlay")
             '())
-- 
cgit v1.2.3