ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

linux-libre: Support module compression.

Browse source 
This commit adds support for GZIP compression for linux-libre kernel
modules. The initrd modules are kept uncompressed as the initrd is already
compressed as a whole.

The linux-libre kernel also supports XZ compression, but as Guix does not have
any available bindings for now, and the compression time is far more
significant, GZIP seems to be a better option.

* gnu/build/linux-modules.scm (modinfo-section-contents): Use
'call-with-gzip-input-port' to read from a module file using '.gz' extension,
(strip-extension): new procedure,
(dot-ko): adapt to support compression,
(ensure-dot-ko): ditto,
(file-name->module-name): ditto,
(find-module-file): ditto,
(load-linux-module*): ditto,
(module-name->file-name/guess): ditto,
(module-name-lookup): ditto,
(write-module-name-database): ditto,
(write-module-alias-database): ditto,
(write-module-device-database): ditto.
* gnu/installer.scm (installer-program): Add "guile-zlib" to the extensions.
* gnu/machine/ssh.scm (machine-check-initrd-modules): Ditto.
* gnu/services.scm (activation-script): Ditto.
* gnu/services/base.scm (default-serial-port): Ditto,
(agetty-shepherd-service): ditto,
(udev-service-type): ditto.
* gnu/system/image.scm (gcrypt-sqlite3&co): Ditto.
* gnu/system/linux-initrd.scm (flat-linux-module-directory): Add "guile-zlib"
to the extensions and make sure that the initrd only contains
uncompressed module files.
* gnu/system/shadow.scm (account-shepherd-service): Add "guile-zlib" to the
extensions.
* guix/profiles.scm (linux-module-database): Ditto.
This commit is contained in:
Mathieu Othacehe 2020-07-05 12:23:21 +02:00
parent 46ef674b34
commit 755f365b02
No known key found for this signature in database
GPG key ID: 8354763531769CA6
9 changed files with 415 additions and 333 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

99
gnu/build/linux-modules.scm
View file

@ -24,6 +24,7 @@ (define-module (gnu build linux-modules)
#:use-module (guix build syscalls)
#:use-module ((guix build utils) #:select (find-files invoke))
#:use-module (guix build union)
#:autoload (zlib) (call-with-gzip-input-port)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
@ -94,10 +95,28 @@ (define (key=value->pair str)
(cons (string->symbol (string-take str =))
(string-drop str (+ 1 =)))))
;; Matches kernel modules, without compression, with GZIP compression or with
;; XZ compression.
(define module-regex "\\.ko(\\.gz|\\.xz)?$")
(define (modinfo-section-contents file)
"Return the contents of the '.modinfo' section of FILE as a list of
key/value pairs.."
(let* ((bv (call-with-input-file file get-bytevector-all))
(define (get-bytevector file)
(cond
((string-suffix? ".ko.gz" file)
(let ((port (open-file file "r0")))
(dynamic-wind
(lambda ()
#t)
(lambda ()
(call-with-gzip-input-port port get-bytevector-all))
(lambda ()
(close-port port)))))
(else
(call-with-input-file file get-bytevector-all))))
(let* ((bv (get-bytevector file))
(elf (parse-elf bv))
(section (elf-section-by-name elf ".modinfo"))
(modinfo (section-contents elf section)))
@ -110,7 +129,7 @@ (define %not-comma
(define (module-formal-name file)
"Return the module name of FILE as it appears in its info section. Usually
the module name is the same as the base name of FILE, modulo hyphens and minus
the \".ko\" extension."
the \".ko[.gz|.xz]\" extension."
(match (assq 'name (modinfo-section-contents file))
(('name . name) name)
(#f #f)))
@ -171,14 +190,25 @@ (define (module-aliases file)
(_ #f))
(modinfo-section-contents file))))
(define dot-ko
(cut string-append <> ".ko"))
(define (strip-extension filename)
(let ((extension (string-index filename #\.)))
(if extension
(string-take filename extension)
filename)))
(define (ensure-dot-ko name)
"Return NAME with a '.ko' prefix appended, unless it already has it."
(if (string-suffix? ".ko" name)
(define (dot-ko name compression)
(let ((suffix (match compression
('xz ".ko.xz")
('gzip ".ko.gz")
(else ".ko"))))
(string-append name suffix)))
(define (ensure-dot-ko name compression)
"Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has
it."
(if (string-contains name ".ko")
name
(dot-ko name)))
(dot-ko name compression)))
(define (normalize-module-name module)
"Return the \"canonical\" name for MODULE, replacing hyphens with
@ -191,9 +221,9 @@ (define (normalize-module-name module)
module))
(define (file-name->module-name file)
"Return the module name corresponding to FILE, stripping the trailing '.ko'
and normalizing it."
(normalize-module-name (basename file ".ko")))
"Return the module name corresponding to FILE, stripping the trailing
'.ko[.gz|.xz]' and normalizing it."
(normalize-module-name (strip-extension (basename file))))
(define (find-module-file directory module)
"Lookup module NAME under DIRECTORY, and return its absolute file name.
@ -208,7 +238,6 @@ (define names
;; List of possible file names. XXX: It would of course be cleaner to
;; have a database that maps module names to file names and vice versa,
;; but everyone seems to be doing hacks like this one. Oh well!
(map ensure-dot-ko
(delete-duplicates
(list module
(normalize-module-name module)
@ -216,11 +245,12 @@ (define names
(case chr
((#\_) #\-)
(else chr)))
module)))))
module))))
(match (find-files directory
(lambda (file stat)
(member (basename file) names)))
(member (strip-extension
(basename file)) names)))
((file)
file)
(()
@ -290,8 +320,8 @@ (define* (load-linux-module* file
(recursive? #t)
(lookup-module dot-ko)
(black-list (module-black-list)))
"Load Linux module from FILE, the name of a '.ko' file; return true on
success, false otherwise. When RECURSIVE? is true, load its dependencies
"Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true
on success, false otherwise. When RECURSIVE? is true, load its dependencies
first (à la 'modprobe'.) The actual files containing modules depended on are
obtained by calling LOOKUP-MODULE with the module name. Modules whose name
appears in BLACK-LIST are not loaded."
@ -523,16 +553,29 @@ (define aliases
;;; Module databases.
;;;
(define (module-name->file-name/guess directory name)
(define* (module-name->file-name/guess directory name
#:key compression)
"Guess the file name corresponding to NAME, a module name. That doesn't
always work because sometimes underscores in NAME map to hyphens (e.g.,
\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\")."
(string-append directory "/" (ensure-dot-ko name)))
\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\"). If the module is
compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the
compression type."
(string-append directory "/" (ensure-dot-ko name compression)))
(define (module-name-lookup directory)
"Return a one argument procedure that takes a module name (e.g.,
\"input_leds\") and returns its absolute file name (e.g.,
\"/.../input-leds.ko\")."
(define (guess-file-name name)
(let ((names (list
(module-name->file-name/guess directory name)
(module-name->file-name/guess directory name
#:compression 'xz)
(module-name->file-name/guess directory name
#:compression 'gzip))))
(or (find file-exists? names)
(first names))))
(catch 'system-error
(lambda ()
(define mapping
@ -541,23 +584,23 @@ (define mapping
(lambda (name)
(or (assoc-ref mapping name)
(module-name->file-name/guess directory name))))
(guess-file-name name))))
(lambda args
(if (= ENOENT (system-error-errno args))
(cut module-name->file-name/guess directory <>)
(cut guess-file-name <>)
(apply throw args)))))
(define (write-module-name-database directory)
"Write a database that maps \"module names\" as they appear in the relevant
ELF section of '.ko' files, to actual file names. This format is
ELF section of '.ko[.gz|.xz]' files, to actual file names. This format is
Guix-specific. It aims to deal with inconsistent naming, in particular
hyphens vs. underscores."
(define mapping
(map (lambda (file)
(match (module-formal-name file)
(#f (cons (basename file ".ko") file))
(#f (cons (strip-extension (basename file)) file))
(name (cons name file))))
(find-files directory "\\.ko$")))
(find-files directory module-regex)))
(call-with-output-file (string-append directory "/modules.name")
(lambda (port)
@ -569,12 +612,12 @@ (define mapping
(pretty-print mapping port))))
(define (write-module-alias-database directory)
"Traverse the '.ko' files in DIRECTORY and create the corresponding
"Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
'modules.alias' file."
(define aliases
(map (lambda (file)
(cons (file-name->module-name file) (module-aliases file)))
(find-files directory "\\.ko$")))
(find-files directory module-regex)))
(call-with-output-file (string-append directory "/modules.alias")
(lambda (port)
@ -616,7 +659,7 @@ (define %not-dash
(char-set-complement (char-set #\-)))
(define (write-module-device-database directory)
"Traverse the '.ko' files in DIRECTORY and create the corresponding
"Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
'modules.devname' file. This file contains information about modules that can
be loaded on-demand, such as file system modules."
(define aliases
@ -624,7 +667,7 @@ (define aliases
(match (aliases->device-tuple (module-aliases file))
(#f #f)
(tuple (cons (file-name->module-name file) tuple))))
(find-files directory "\\.ko$")))
(find-files directory module-regex)))
(call-with-output-file (string-append directory "/modules.devname")
(lambda (port)

3
gnu/installer.scm
View file

@ -342,7 +342,8 @@ (define installer-builder
;; packages …), etc. modules.
(with-extensions (list guile-gcrypt guile-newt
guile-parted guile-bytestructures
guile-json-3 guile-git guix)
guile-json-3 guile-git guile-zlib
guix)
(with-imported-modules `(,@(source-module-closure
`(,@modules
(gnu services herd)

7
gnu/machine/ssh.scm
View file

@ -21,6 +21,7 @@ (define-module (gnu machine ssh)
#:use-module (gnu bootloader)
#:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:autoload (gnu packages guile) (guile-zlib)
#:use-module (gnu system)
#:use-module (gnu system file-systems)
#:use-module (gnu system uuid)
@ -248,6 +249,7 @@ (define remote-exp
'((gnu build file-systems)
(gnu build linux-modules)
(gnu system uuid)))
(with-extensions (list guile-zlib)
#~(begin
(use-modules (gnu build file-systems)
(gnu build linux-modules)
@ -262,8 +264,9 @@ (define dev
#~(find-partition-by-label
#$(file-system-label->string device)))))
(missing-modules dev '#$(operating-system-initrd-modules
(machine-operating-system machine)))))))
(missing-modules dev
'#$(operating-system-initrd-modules
(machine-operating-system machine))))))))
(remote-let ((missing remote-exp))
(unless (null? missing)

14
gnu/services.scm
View file

@ -35,6 +35,7 @@ (define-module (gnu services)
#:use-module (guix modules)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages guile)
#:use-module (gnu packages hurd)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
@ -585,13 +586,14 @@ (define actions
(with-imported-modules (source-module-closure
'((gnu build activation)
(guix build utils)))
(with-extensions (list guile-zlib)
#~(begin
(use-modules (gnu build activation)
(guix build utils))
;; Make sure the user accounting database exists. If it
;; does not exist, 'setutxent' does not create it and
;; thus there is no accounting at all.
;; Make sure the user accounting database exists. If
;; it does not exist, 'setutxent' does not create it
;; and thus there is no accounting at all.
(close-port (open-file "/var/run/utmpx" "a0"))
;; Same for 'wtmp', which is populated by mingetty et
@ -599,14 +601,14 @@ (define actions
(mkdir-p "/var/log")
(close-port (open-file "/var/log/wtmp" "a0"))
;; Set up /run/current-system. Among other things this
;; sets up locales, which the activation snippets
;; Set up /run/current-system. Among other things
;; this sets up locales, which the activation snippets
;; executed below may expect.
(activate-current-system)
;; Run the services' activation snippets.
;; TODO: Use 'load-compiled'.
(for-each primitive-load '#$actions)))))
(for-each primitive-load '#$actions))))))
(define (gexps->activation-gexp gexps)
"Return a gexp that runs the activation script containing GEXPS."

28
gnu/services/base.scm
View file

@ -50,6 +50,7 @@ (define-module (gnu services base)
#:select (coreutils glibc glibc-utf8-locales))
#:use-module (gnu packages package-management)
#:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
#:use-module ((gnu packages guile) #:select (guile-zlib))
#:use-module (gnu packages linux)
#:use-module (gnu packages terminals)
#:use-module ((gnu build file-systems)
@ -836,6 +837,7 @@ (define (default-serial-port)
to use as the tty. This is primarily useful for headless systems."
(with-imported-modules (source-module-closure
'((gnu build linux-boot))) ;for 'find-long-options'
(with-extensions (list guile-zlib)
#~(begin
;; console=device,options
;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
@ -844,7 +846,8 @@ (define (default-serial-port)
(let* ((not-comma (char-set-complement (char-set #\,)))
(command (linux-command-line))
(agetty-specs (find-long-options "agetty.tty" command))
(console-specs (filter (lambda (spec)
(console-specs
(filter (lambda (spec)
(and (string-prefix? "tty" spec)
(not (or
(string-prefix? "tty0" spec)
@ -865,7 +868,7 @@ (define (default-serial-port)
;; Extract device name from first spec.
(match (string-tokenize spec not-comma)
((device-name _ ...)
device-name))))))))
device-name)))))))))
(define agetty-shepherd-service
(match-lambda
@ -890,6 +893,7 @@ (define agetty-shepherd-service
(start
(with-imported-modules (source-module-closure
'((gnu build linux-boot)))
(with-extensions (list guile-zlib)
#~(lambda args
(let ((defaulted-tty #$(or tty (default-serial-port))))
(apply
@ -921,10 +925,10 @@ (define agetty-shepherd-service
#$@(if no-clear?
#~("--noclear")
#~())
;;; FIXME This doesn't work as expected. According to agetty(8), if this option
;;; is not passed, then the default is 'auto'. However, in my tests, when that
;;; option is selected, agetty never presents the login prompt, and the
;;; term-ttyS0 service respawns every few seconds.
;;; FIXME This doesn't work as expected. According to agetty(8), if this
;;; option is not passed, then the default is 'auto'. However, in my tests,
;;; when that option is selected, agetty never presents the login prompt, and
;;; the term-ttyS0 service respawns every few seconds.
#$@(if local-line
#~(#$(match local-line
('auto "--local-line=auto")
@ -956,7 +960,8 @@ (define agetty-shepherd-service
#~("--keep-baud")
#~())
#$@(if timeout
#~("--timeout" #$(number->string timeout))
#~("--timeout"
#$(number->string timeout))
#~())
#$@(if detect-case?
#~("--detect-case")
@ -1005,7 +1010,7 @@ (define agetty-shepherd-service
#~(#$term)
#~())))
(const #f)) ; never start.
args)))))
args))))))
(stop #~(make-kill-destructor)))))))
(define agetty-service-type
@ -1939,6 +1944,7 @@ (define udev-shepherd-service
(start
(with-imported-modules (source-module-closure
'((gnu build linux-boot)))
(with-extensions (list guile-zlib)
#~(lambda ()
(define udevd
;; 'udevd' from eudev.
@ -1978,7 +1984,9 @@ (define (wait-for-udevd)
(make-static-device-nodes directory))
(umask old-umask))
(let ((pid (fork+exec-command (list udevd)
(let ((pid
(fork+exec-command
(list udevd)
#:environment-variables
(cons*
;; The first one is for udev, the second one for
@ -2002,7 +2010,7 @@ (define (wait-for-udevd)
;; Wait for things to settle down.
(system* #$(file-append udev "/bin/udevadm")
"settle")
pid))))
pid)))))
(stop #~(make-kill-destructor))
;; When halting the system, 'udev' is actually killed by

2
gnu/system/image.scm
View file

@ -141,7 +141,7 @@ (define gcrypt-sqlite3&co
(match (package-transitive-propagated-inputs package)
(((labels packages) ...)
packages))))
(list guile-gcrypt guile-sqlite3)))
(list guile-gcrypt guile-sqlite3 guile-zlib)))
(define-syntax-rule (with-imported-modules* gexp* ...)
(with-extensions gcrypt-sqlite3&co

30
gnu/system/linux-initrd.scm
View file

@ -77,6 +77,9 @@ (define init
(program-file "init" exp #:guile guile))
(define builder
;; Do not use "guile-zlib" extension here, otherwise it would drag the
;; non-static "zlib" package to the initrd closure. It is not needed
;; anyway because the modules are stored uncompressed within the initrd.
(with-imported-modules (source-module-closure
'((gnu build linux-initrd)))
#~(begin
@ -111,11 +114,16 @@ (define builder
(define (flat-linux-module-directory linux modules)
"Return a flat directory containing the Linux kernel modules listed in
MODULES and taken from LINUX."
(define imported-modules
(source-module-closure '((gnu build linux-modules)
(guix build utils))))
(define build-exp
(with-imported-modules (source-module-closure
'((gnu build linux-modules)))
(with-imported-modules imported-modules
(with-extensions (list guile-zlib)
#~(begin
(use-modules (gnu build linux-modules)
(guix build utils)
(srfi srfi-1)
(srfi srfi-26))
@ -126,19 +134,29 @@ (define modules
(let* ((lookup (cut find-module-file module-dir <>))
(modules (map lookup '#$modules)))
(append modules
(recursive-module-dependencies modules
(recursive-module-dependencies
modules
#:lookup-module lookup))))
(define (maybe-uncompress file)
;; If FILE is a compressed module, uncompress it, as the initrd
;; is already gzipped as a whole.
(cond
((string-contains file ".ko.gz")
(invoke #+(file-append gzip "/bin/gunzip") file))))
(mkdir #$output)
(for-each (lambda (module)
(format #t "copying '~a'...~%" module)
(copy-file module
(let ((out-module
(string-append #$output "/"
(basename module))))
(format #t "copying '~a'...~%" module)
(copy-file module out-module)
(maybe-uncompress out-module)))
(delete-duplicates modules))
;; Hyphen or underscore? This database tells us.
(write-module-name-database #$output))))
(write-module-name-database #$output)))))
(computed-file "linux-modules" build-exp))

4
gnu/system/shadow.scm
View file

@ -34,6 +34,7 @@ (define-module (gnu system shadow)
#:use-module ((gnu packages admin)
#:select (shadow))
#:use-module (gnu packages bash)
#:use-module (gnu packages guile)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
@ -324,11 +325,12 @@ (define accounts
(start (with-imported-modules (source-module-closure
'((gnu build activation)
(gnu system accounts)))
(with-extensions (list guile-zlib)
#~(lambda ()
(activate-user-home
(map sexp->user-account
(list #$@(map user-account->gexp accounts))))
#t))) ;success
#t)))) ;success
(documentation "Create user home directories."))))
(define (shells-file shells)

7
guix/profiles.scm
View file

@ -1205,10 +1205,15 @@ (define (linux-module-database manifest)
This is meant to be used as a profile hook."
(define kmod ; lazy reference
(module-ref (resolve-interface '(gnu packages linux)) 'kmod))
(define guile-zlib
(module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
(define build
(with-imported-modules (source-module-closure
'((guix build utils)
(gnu build linux-modules)))
(with-extensions (list guile-zlib)
#~(begin
(use-modules (ice-9 ftw)
(ice-9 match)
@ -1241,7 +1246,7 @@ (define build
;; CONFIG_MODULES=n.
(mkdir #$output))
(_ (error "Specified Linux kernel and Linux kernel modules
are not all of the same version")))))))
are not all of the same version"))))))))
(gexp->derivation "linux-module-database" build
#:local-build? #t
#:substitutable? #f