01/02: linux-boot: Add make-static-device-nodes.

[Danny Milosavljevic]

dannym pushed a commit to branch master
in repository guix.

commit 97817e7f18bd3bd95152e46239ad96928678e944
Author: Danny Milosavljevic <address@hidden>
Date:   Sat Dec 16 00:16:40 2017 +0100

    linux-boot: Add make-static-device-nodes.
    
    * gnu/build/linux-boot.scm (make-static-device-nodes): New variable.
    (<device-node>): New variable.
    (read-static-device-nodes): New variable.
    (report-system-error): New variable.
    (catch-system-error): New variable.
    (create-device-node): New variable.
    (mkdir-p*): New variable.
    
    Co-Authored-By: Ludovic Courtès <address@hidden>
---
 gnu/build/linux-boot.scm | 107 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 107 insertions(+)

diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 2547f1e..4dd7401 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -22,8 +22,11 @@
   #: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 ftw)
   #:use-module (guix build utils)
   #:use-module ((guix build syscalls)
@@ -35,6 +38,7 @@
             linux-command-line
             find-long-option
             make-essential-device-nodes
+            make-static-device-nodes
             configure-qemu-networking
 
             bind-mount
@@ -105,6 +109,109 @@ with the given MAJOR number, starting with MINOR."
              'block-special #o644 (device-number major (+ minor i)))
       (loop (+ i 1)))))
 
+;; Representation of a /dev node.
+(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 (read-static-device-nodes port)
+  "Read from PORT a list of <device-node> written in the format used by
+/lib/modules/*/*.devname files."
+  (let loop ((line (read-line port)))
+    (if (eof-object? line)
+      '()
+      (match (string-split line #\space)
+       (((? (cut string-prefix? "#" <>)) _ ...)
+        (loop (read-line port)))
+       ((module-name device-name device-spec)
+        (let* ((device-parts
+               (string-match "([bc])([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 port)))))
+       (_
+        (begin
+          (format (current-error-port)
+                  "read-static-device-nodes: ignored devname line '~a'~%" line)
+          (loop (read-line port))))))))
+
+(define* (mkdir-p* dir #:optional (mode #o755))
+  "This is a variant of 'mkdir-p' that works around
+<http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call."
+  (define absolute?
+    (string-prefix? "/" dir))
+
+  (define not-slash
+    (char-set-complement (char-set #\/)))
+
+  (let loop ((components (string-tokenize dir not-slash))
+             (root       (if absolute?
+                             ""
+                             ".")))
+    (match components
+      ((head tail ...)
+       (let ((path (string-append root "/" head)))
+         (catch 'system-error
+           (lambda ()
+             (mkdir path mode)
+             (loop tail path))
+           (lambda args
+             (if (= EEXIST (system-error-errno args))
+                 (loop tail path)
+                 (apply throw args))))))
+      (() #t))))
+
+(define (report-system-error name . args)
+  "Report a system error for the file NAME."
+  (let ((errno (system-error-errno args)))
+    (format (current-error-port) "could not create '~a': ~a~%" name
+            (strerror errno))))
+
+;; Catch a system-error, log it and don't die from it.
+(define-syntax-rule (catch-system-error name exp)
+  (catch 'system-error
+    (lambda ()
+      exp)
+    (lambda args
+      (apply report-system-error name args))))
+
+;; Create a device node like the <device-node> passed here on the filesystem.
+(define create-device-node
+  (match-lambda
+    (($ <device-node> xname type major minor module)
+     (let ((name (string-append "/dev/" xname)))
+       (mkdir-p* (dirname name))
+       (catch-system-error name
+         (mknod name type #o600 (device-number major minor)))))))
+
+(define* (make-static-device-nodes linux-release-module-directory)
+  "Create static device nodes required by the given Linux release.
+This is required in order to solve a chicken-or-egg problem:
+The Linux kernel has a feature to autoload modules when a device is first
+accessed.
+And udev has a feature to set the permissions of static nodes correctly
+when it is starting up and also to automatically create nodes when hardware
+is hotplugged. That leaves universal device files which are not linked to
+one specific hardware device. These we have to create."
+  (let ((devname-name (string-append linux-release-module-directory "/"
+                                     "modules.devname")))
+    (for-each create-device-node
+              (call-with-input-file devname-name
+                                    read-static-device-nodes))))
+
 (define* (make-essential-device-nodes #:key (root "/"))
   "Make essential device nodes under ROOT/dev."
   ;; The hand-made devtmpfs/udev!