From mboxrd@z Thu Jan 1 00:00:00 1970 From: Danny Milosavljevic Subject: bug#22050: [PATCH v5 1/2] linux-boot: Add make-static-device-nodes. Date: Thu, 14 Dec 2017 22:25:47 +0100 Message-ID: <20171214212548.655-2-dannym@scratchpost.org> References: <20171214195636.787-1-dannym@scratchpost.org> <20171214212548.655-1-dannym@scratchpost.org> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:36595) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ePb12-0005pb-39 for bug-guix@gnu.org; Thu, 14 Dec 2017 16:26:05 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ePb10-0004vX-TP for bug-guix@gnu.org; Thu, 14 Dec 2017 16:26:04 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:53742) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1ePb10-0004v7-O8 for bug-guix@gnu.org; Thu, 14 Dec 2017 16:26:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ePb10-0006B7-ID for bug-guix@gnu.org; Thu, 14 Dec 2017 16:26:02 -0500 Sender: "Debbugs-submit" Resent-Message-ID: In-Reply-To: <20171214212548.655-1-dannym@scratchpost.org> List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guix-bounces+gcggb-bug-guix=m.gmane.org@gnu.org Sender: "bug-Guix" To: 22050@debbugs.gnu.org, ludo@gnu.org * gnu/build/linux-boot.scm (make-static-device-nodes): New variable. : 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 --- 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..d9ced187c 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 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 "([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 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 + (($ 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-release-module-directory) + (let ((devname-name (string-append linux-release-module-directory "/" + "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!