Package: guix-patches;
Reported by: Danny Milosavljevic <dannym <at> scratchpost.org>
Date: Tue, 22 Oct 2019 15:23:01 UTC
Severity: normal
Tags: patch
Done: Danny Milosavljevic <dannym <at> scratchpost.org>
Bug is archived. No further changes may be made.
Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: guix-patches <at> gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org> Subject: [PATCH] guix: Allow multiple packages to provide Linux modules in the system profile. Date: Tue, 22 Oct 2019 17:22:38 +0200
* guix/profiles.scm (linux-module-database): New procedure.
(%default-profile-hooks): Add it.
* gnu/system.scm (operating-system-profile): Add kernel to what
profile-service-type gives.
* gnu/services.scm (%modprobe-wrapper): Use that profile.
* guix/build/linux-module-build-system.scm (install): Disable DEPMOD.
---
gnu/services.scm | 7 ++-
gnu/system.scm | 8 ++-
guix/build/linux-module-build-system.scm | 5 +-
guix/profiles.scm | 75 +++++++++++++++++++++++-
4 files changed, 87 insertions(+), 8 deletions(-)
diff --git a/gnu/services.scm b/gnu/services.scm
index 6ee05d4580..2a6d2bc464 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -491,7 +491,12 @@ ACTIVATION-SCRIPT-TYPE."
(program-file "modprobe"
#~(begin
(setenv "LINUX_MODULE_DIRECTORY"
- "/run/booted-system/kernel/lib/modules")
+ (if (file-exists?
+ "/run/booted-system/profile/lib/modules")
+ "/run/booted-system/profile/lib/modules"
+ ;; Provides compatibility with previous
+ ;; Guix generations.
+ "/run/booted-system/kernel/lib/modules"))
(apply execl #$modprobe
(cons #$modprobe (cdr (command-line))))))))
diff --git a/gnu/system.scm b/gnu/system.scm
index a353b1a5c8..66270b38bb 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -887,12 +887,14 @@ we're running in the final root."
(define* (operating-system-profile os)
"Return a derivation that builds the system profile of OS."
(mlet* %store-monad
- ((services -> (operating-system-services os))
+ ((kernel -> (operating-system-kernel os))
+ (services -> (operating-system-services os))
(profile (fold-services services
- #:target-type profile-service-type)))
+ #:target-type
+ profile-service-type)))
(match profile
(("profile" profile)
- (return profile)))))
+ (return (cons kernel profile)))))) ; FIXME: Doesn't work for some reason. I don't think this place is ever reached.
(define (operating-system-root-file-system os)
"Return the root file system of OS."
diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm
index cd76df2de7..e4e6993a49 100644
--- a/guix/build/linux-module-build-system.scm
+++ b/guix/build/linux-module-build-system.scm
@@ -60,15 +60,14 @@
;; part.
(define* (install #:key inputs native-inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
- (moddir (string-append out "/lib/modules"))
- (kmod (assoc-ref (or native-inputs inputs) "kmod")))
+ (moddir (string-append out "/lib/modules")))
;; Install kernel modules
(mkdir-p moddir)
(invoke "make" "-C"
(string-append (assoc-ref inputs "linux-module-builder")
"/lib/modules/build")
(string-append "M=" (getcwd))
- (string-append "DEPMOD=" kmod "/bin/depmod")
+ "DEPMOD=true" ; disable depmod.
(string-append "MODULE_DIR=" moddir)
(string-append "INSTALL_PATH=" out)
(string-append "INSTALL_MOD_PATH=" out)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index cd3b21e390..fd77392588 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -9,6 +9,7 @@
;;; Copyright © 2017 Huang Ying <huang.ying.caritas <at> gmail.com>
;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
;;; Copyright © 2019 Kyle Meyer <kyle <at> kyleam.com>
+;;; Copyright © 2019 Danny Milosavljevic <dannym <at> scratchpost.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -1125,6 +1126,77 @@ for both major versions of GTK+."
(hook . gtk-im-modules)))
(return #f)))))
+(define (linux-module-database manifest)
+ (mlet %store-monad
+ ((kmod (manifest-lookup-package manifest "kmod")))
+ (define build
+ (with-imported-modules '((guix build utils)
+ (guix build union))
+ #~(begin
+ (use-modules (srfi srfi-1)
+ (srfi srfi-26)
+ (guix build utils)
+ (guix build union)
+ (ice-9 ftw)
+ (ice-9 match))
+ (let* ((inputs '#$(manifest-inputs manifest))
+ (input-files (lambda (path)
+ (filter file-exists?
+ (map (cut string-append <> path) inputs))))
+ (module-directories (input-files "/lib/modules"))
+ (System.maps (input-files "/System.map"))
+ (Module.symverss (input-files "/Module.symvers"))
+ (directory-entries (lambda (directory-name)
+ (filter (lambda (basename)
+ (not (string-prefix? "."
+ basename)))
+ (scandir directory-name))))
+ ;; Note: Should result in one entry.
+ (versions (append-map directory-entries module-directories)))
+ ;; TODO: if len(module-directories) == 1: return module-directories[0]
+ (mkdir-p (string-append #$output "/lib/modules"))
+ ;; Iterate over each kernel version directory (usually one).
+ (for-each (lambda (version)
+ (let ((destination-directory (string-append #$output "/lib/modules/" version)))
+ (when (not (file-exists? destination-directory)) ; unique
+ (union-build destination-directory
+ ;; All directories with the same version as us.
+ (filter-map (lambda (directory-name)
+ (if (member version
+ (directory-entries directory-name))
+ (string-append directory-name "/" version)
+ #f))
+ module-directories)
+ #:create-all-directories? #t)
+ ;; Delete generated files (they will be recreated shortly).
+ (for-each (lambda (basename)
+ (when (string-prefix? "modules." basename)
+ (false-if-file-not-found
+ (delete-file
+ (string-append
+ destination-directory "/"
+ basename)))))
+ (directory-entries destination-directory))
+ (unless (zero? (system* (string-append #$kmod "/bin/depmod")
+ "-e" ; Report symbols that aren't supplied
+ "-w" ; Warn on duplicates
+ "-b" #$output ; destination-directory
+ "-F" (match System.maps
+ ((x) x))
+ "-E" (match Module.symverss
+ ((x) x))
+ version))
+ (display "FAILED\n" (current-error-port))
+ (exit #f)))))
+ versions)
+ (exit #t)))))
+ (gexp->derivation "linux-module-database" build
+ #:local-build? #t
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . linux-module-database)))))
+
(define (xdg-desktop-database manifest)
"Return a derivation that builds the @file{mimeinfo.cache} database from
desktop files. It's used to query what applications can handle a given
@@ -1425,7 +1497,8 @@ MANIFEST."
gtk-im-modules
texlive-configuration
xdg-desktop-database
- xdg-mime-database))
+ xdg-mime-database
+ linux-module-database))
(define* (profile-derivation manifest
#:key
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.