Package: guix-patches;
Reported by: Danny Milosavljevic <dannym <at> scratchpost.org>
Date: Sun, 25 Feb 2018 11:47:02 UTC
Severity: important
Tags: patch
Message #194 received at 30604 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: 30604 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org> Subject: [PATCH v8 7/7] linux-initrd: Factorize %modprobe and flat-linux-module-directory. Date: Sat, 3 Mar 2018 14:55:33 +0100
* gnu/build/linux-modules.scm (module-aliases->module-file-names): New
procedure.
* gnu/system/linux-initrd.scm (%modprobe): Use
module-aliases->module-file-names.
(flat-linux-module-directory): Use module-aliases->module-file-names.
---
gnu/build/linux-modules.scm | 56 +++++++++++++++++++++-
gnu/system/linux-initrd.scm | 110 ++++++++++++++++++--------------------------
2 files changed, 100 insertions(+), 66 deletions(-)
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index af217c974..44059ad93 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -21,6 +21,7 @@
#:use-module (guix elf)
#:use-module (guix glob)
#:use-module (guix build syscalls)
+ #:use-module (guix build utils) ; find-files
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
@@ -28,9 +29,12 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 ftw)
#:export (dot-ko
ensure-dot-ko
module-aliases
+ module-aliases->module-file-names
module-dependencies
recursive-module-dependencies
modules-loaded
@@ -385,7 +389,7 @@ ALIAS is a string like \"scsi:t-0x00\" as returned by
(define (install-module-files module-files output)
"Install MODULE-FILES to OUTPUT.
-Precondition: OUTPUT is an empty directory."
+Precondition: OUTPUT is an empty directory except for \"modules.builtin\"."
(let ((aliases
(map (lambda (module-file-name)
(format #t "copying '~a'...~%" module-file-name)
@@ -431,4 +435,54 @@ Precondition: OUTPUT is an empty directory."
(_ #f))
aliases))))))
+(define (module-aliases->module-file-names linux aliases)
+ "Resolve ALIASES to module file names, including their dependencies (which will appear
+first). Each alias will map to a list of module file names.
+LINUX is the directory containing \"lib\"."
+ (define (string->regexp str)
+ ;; Return a regexp that matches STR exactly.
+ (string-append "^" (regexp-quote str) "$"))
+
+ (define module-dir
+ (string-append linux "/lib/modules"))
+
+ (define (find-only-entry directory)
+ (match (scandir directory)
+ (("." ".." basename)
+ (string-append directory "/" basename))))
+
+ (define linux-release-module-directory
+ (find-only-entry module-dir))
+
+ (define known-module-aliases*
+ (known-module-aliases
+ (string-append linux-release-module-directory
+ "/modules.alias")))
+ (define (resolve-alias alias)
+ "If possible, resolve ALIAS to a list of module names.
+Otherwise return just ALIAS as possible module names."
+ (match (delete-duplicates (matching-modules alias
+ known-module-aliases*))
+ (()
+ (list alias))
+ (items
+ items)))
+
+ (define (lookup module)
+ (let ((name (ensure-dot-ko module)))
+ (match (find-files module-dir (string->regexp name))
+ ((file)
+ file)
+ (()
+ (error "module not found" name module-dir))
+ ((_ ...)
+ (error "several modules by that name"
+ name module-dir)))))
+ (append-map (lambda (alias)
+ (let ((modules (map lookup (resolve-alias alias))))
+ (append (recursive-module-dependencies modules
+ #:lookup-module
+ lookup) modules)))
+ aliases))
+
;;; linux-modules.scm ends here
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 8050ac47e..dc826c63e 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -58,35 +58,14 @@
(define* (%modprobe linux-module-directory #:key
(guile %guile-static-stripped))
+ "Minimal implementation of modprobe for our initrd.
+LINUX-MODULE-DIRECTORY is the directory that contains \"lib\"."
(program-file "modprobe"
(with-imported-modules (source-module-closure
'((gnu build linux-modules)))
#~(begin
(use-modules (gnu build linux-modules) (ice-9 getopt-long)
- (ice-9 match) (srfi srfi-1) (ice-9 ftw))
- (define (find-only-entry directory)
- (match (scandir directory)
- (("." ".." basename)
- (string-append directory "/" basename))))
- (define (resolve-alias alias)
- (let* ((linux-release-module-directory
- (find-only-entry (string-append "/lib/modules"))))
- (match (delete-duplicates (matching-modules alias
- (known-module-aliases
- (string-append linux-release-module-directory
- "/modules.alias"))))
- (()
- (error "no alias by that name" alias))
- (items
- items))))
- (define (lookup-module module)
- (let* ((linux-release-module-directory
- (find-only-entry (string-append "/lib/modules")))
- (file-name (string-append linux-release-module-directory
- "/" (ensure-dot-ko module))))
- (if (file-exists? file-name)
- file-name
- (error "no module file found for module" module))))
+ (ice-9 match) (srfi srfi-1))
(define option-spec
'((quiet (single-char #\q) (value #f))))
(define options
@@ -98,22 +77,31 @@
(for-each (match-lambda
(('quiet . #t)
#f)
- ((() modules ...)
- (for-each (lambda (alias)
- (catch #t
- (lambda ()
- (let ((modules (resolve-alias alias))) (for-each (lambda (module)
- (load-linux-module*
- (lookup-module module)
- #:lookup-module
- lookup-module))
- modules)))
- (lambda (key . args)
- (display (cons* key args)
- (current-error-port))
- (newline (current-error-port))
- (set! exit-status 1))))
- modules)))
+ ((() aliases ...)
+ (catch #t
+ (lambda ()
+ (let ((module-file-names
+ (module-aliases->module-file-names
+ #$linux-module-directory aliases)))
+ (for-each (lambda (name)
+ (catch 'system-error
+ (lambda ()
+ (when (not (load-linux-module* name
+ #:recursive?
+ #f))
+ (set! exit-status 1)))
+ (lambda (key . args)
+ (when (not (= EEXIST
+ (system-error-errno
+ (cons key args))))
+ (print-exception (current-error-port)
+ #f key args)
+ (set! exit-status 1)))))
+ module-file-names)))
+ (lambda (key . args)
+ (print-exception (current-error-port)
+ #f key args)
+ (set! exit-status 1)))))
options)
(exit exit-status))))
#:guile guile))
@@ -173,17 +161,17 @@ the derivations referenced by EXP are automatically copied to the initrd."
#:references-graphs `(("init-closure" ,init)
("modprobe-closure" ,modprobe))))
-(define (flat-linux-module-directory linux modules)
- "Return a flat directory containing the Linux kernel modules listed in
-MODULES and taken from LINUX."
+(define (flat-linux-module-directory linux aliases)
+ "Return a flat directory containing the Linux kernel modules resolved by
+ALIASES and taken from LINUX."
(define build-exp
(with-imported-modules (source-module-closure
'((guix build utils)
(gnu build linux-modules)))
#~(begin
- (use-modules (ice-9 match) (ice-9 regex) (ice-9 ftw)
+ (use-modules (ice-9 match) (ice-9 ftw)
(srfi srfi-1)
- (guix build utils)
+ (guix build utils) ; TODO: Remove
(gnu build linux-modules))
(define (string->regexp str)
@@ -193,33 +181,25 @@ MODULES and taken from LINUX."
(define module-dir
(string-append #$linux "/lib/modules"))
- (define (lookup module)
- (let ((name (ensure-dot-ko module)))
- (match (find-files module-dir (string->regexp name))
- ((file)
- file)
- (()
- (error "module not found" name module-dir))
- ((_ ...)
- (error "several modules by that name"
- name module-dir)))))
+ (define (find-only-entry directory)
+ (match (scandir directory)
+ (("." ".." basename)
+ (string-append directory "/" basename))))
+
+ (define linux-release-module-directory
+ (find-only-entry module-dir))
(define modules
- (let ((modules (map lookup '#$modules)))
- (append modules
- (recursive-module-dependencies modules
- #:lookup-module lookup))))
+ (module-aliases->module-file-names #$linux '#$aliases))
(define version
- (match
- (filter
- (lambda (name)
- (not (string-prefix? "." name)))
- (scandir module-dir))
- ((item) item)))
+ (basename linux-release-module-directory))
(let ((output (string-append #$output "/lib/modules/" version)))
(mkdir-p output)
+ (install-file
+ (string-append linux-release-module-directory "/modules.builtin")
+ output)
(install-module-files (delete-duplicates modules) output))
#t)))
(computed-file "linux-modules" build-exp))
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.