bug#22050: [PATCH v4 1/2] linux-boot: Add make-static-device-nodes.

[Danny Milosavljevic <dannym@scratchpost.org>]

* gnu/build/linux-boot.scm (make-static-device-nodes): New variable.
<device-node>: New variable.
parse-static-nodes-from-devname-file: New variable.
not-slash: New variable.
report-system-error: New variable.
catch-system-error: New variable.
create-device-node: New variable.

Co-Authored-By: Ludovic Courtès <ludo@gnu.org>    
---
 gnu/build/linux-boot.scm | 81 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 81 insertions(+)

diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 2547f1e0a..c83bbcda4 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -22,8 +22,12 @@
   #:use-module (system repl error-handling)
   #:autoload   (system repl repl) (start-repl)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 popen)
   #:use-module (ice-9 ftw)
   #:use-module (guix build utils)
   #:use-module ((guix build syscalls)
@@ -35,6 +39,7 @@
             linux-command-line
             find-long-option
             make-essential-device-nodes
+            make-static-device-nodes
             configure-qemu-networking
 
             bind-mount
@@ -105,6 +110,82 @@ with the given MAJOR number, starting with MINOR."
              'block-special #o644 (device-number major (+ minor i)))
       (loop (+ i 1)))))
 
+(define-record-type <device-node>
+  (device-node name type major minor module)
+  device-node?
+  (name device-node-name)
+  (type device-node-type)
+  (major device-node-major)
+  (minor device-node-minor)
+  (module device-node-module))
+
+(define (parse-static-nodes-from-devname-file devname-name)
+  (call-with-input-file devname-name
+    (lambda (input-file)
+      (let loop ((line (read-line input-file)))
+        (if (eof-object? line)
+          '()
+          (match (string-split line #\space)
+           (("#" _ ...)
+            (loop (read-line input-file)))
+           ((module-name device-name device-spec)
+            (let* ((device-parts (string-match "(.)([0-9][0-9]*):([0-9][0-9]*)" device-spec))
+                   (type-string (match:substring device-parts 1))
+                   (type (match type-string
+                          ("c" 'char-special)
+                          ("b" 'block-special)))
+                   (major-string (match:substring device-parts 2))
+                   (major (string->number major-string 10))
+                   (minor-string (match:substring device-parts 3))
+                   (minor (string->number minor-string 10)))
+              (cons (device-node device-name type major minor module-name)
+                    (loop (read-line input-file)))))
+           (_
+            (begin
+              (format (current-error-port) "~a: ignored devname line '~a'~%"
+                      devname-name line)
+              (loop (read-line input-file))))))))))
+
+(define not-slash
+  (char-set-complement (char-set #\/)))
+
+(define (report-system-error name . args)
+  (let ((errno (system-error-errno args)))
+        (format (current-error-port) "could not create '~a': ~a~%" name
+                (strerror errno))))
+
+(define-syntax-rule (catch-system-error name exp)
+  (catch 'system-error
+    (lambda ()
+      exp)
+    (lambda args
+      (apply report-system-error name args))))
+
+(define create-device-node
+  (match-lambda
+    (($ <device-node> name type major minor module)
+     (let ((name-parts (string-tokenize name not-slash)))
+       (let loop ((prefix "/dev")
+                  (name-parts name-parts))
+         (match name-parts
+          ((leaf)
+           (let ((prefix (string-append prefix "/" leaf)))
+             (catch-system-error prefix
+               (mknod prefix type #o600 (device-number major minor)))))
+          ((prefix-addition tails ...)
+           (let ((prefix (string-append prefix "/" prefix-addition)))
+             (unless (file-exists? prefix)
+               (mkdir prefix #o755))
+             (loop prefix tails)))))))))
+
+(define* (make-static-device-nodes linux-module-directory)
+  (let* ((kernel-release (utsname:release (uname)))
+         (devname-name (string-append linux-module-directory "/"
+                                      kernel-release "/"
+                                      "modules.devname")))
+       (for-each create-device-node
+                 (parse-static-nodes-from-devname-file devname-name))))
+
 (define* (make-essential-device-nodes #:key (root "/"))
   "Make essential device nodes under ROOT/dev."
   ;; The hand-made devtmpfs/udev!