aboutsummaryrefslogtreecommitdiff
path: root/gnu/build/linux-boot.scm
diff options
context:
space:
mode:
authorDanny Milosavljevic <dannym@scratchpost.org>2017-12-16 00:16:40 +0100
committerDanny Milosavljevic <dannym@scratchpost.org>2017-12-16 07:33:09 +0100
commit97817e7f18bd3bd95152e46239ad96928678e944 (patch)
treeb53456638df011edb833b0ad3b193dcf2f9ccbbd /gnu/build/linux-boot.scm
parent5985d01bd84a10439c5c0418bf2979aaa8a08b1a (diff)
downloadguix-97817e7f18bd3bd95152e46239ad96928678e944.tar
guix-97817e7f18bd3bd95152e46239ad96928678e944.tar.gz
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 <ludo@gnu.org>
Diffstat (limited to 'gnu/build/linux-boot.scm')
-rw-r--r--gnu/build/linux-boot.scm107
1 files changed, 107 insertions, 0 deletions
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 2547f1e0af..4dd740174e 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!