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

3
gnu/installer.scm
View file

@ -342,7 +342,8 @@ (define installer-builder
;; packages …), etc. modules. ;; packages …), etc. modules.
(with-extensions (list guile-gcrypt guile-newt (with-extensions (list guile-gcrypt guile-newt
guile-parted guile-bytestructures guile-parted guile-bytestructures
guile-json-3 guile-git guix) guile-json-3 guile-git guile-zlib
guix)
(with-imported-modules `(,@(source-module-closure (with-imported-modules `(,@(source-module-closure
`(,@modules `(,@modules
(gnu services herd) (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 bootloader)
#:use-module (gnu machine) #:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt) #:autoload (gnu packages gnupg) (guile-gcrypt)
#:autoload (gnu packages guile) (guile-zlib)
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
@ -248,6 +249,7 @@ (define remote-exp
'((gnu build file-systems) '((gnu build file-systems)
(gnu build linux-modules) (gnu build linux-modules)
(gnu system uuid))) (gnu system uuid)))
(with-extensions (list guile-zlib)
#~(begin #~(begin
(use-modules (gnu build file-systems) (use-modules (gnu build file-systems)
(gnu build linux-modules) (gnu build linux-modules)
@ -262,8 +264,9 @@ (define dev
#~(find-partition-by-label #~(find-partition-by-label
#$(file-system-label->string device))))) #$(file-system-label->string device)))))
(missing-modules dev '#$(operating-system-initrd-modules (missing-modules dev
(machine-operating-system machine))))))) '#$(operating-system-initrd-modules
(machine-operating-system machine))))))))
(remote-let ((missing remote-exp)) (remote-let ((missing remote-exp))
(unless (null? missing) (unless (null? missing)

14
gnu/services.scm
View file

@ -35,6 +35,7 @@ (define-module (gnu services)
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (gnu packages base) #:use-module (gnu packages base)
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages guile)
#:use-module (gnu packages hurd) #:use-module (gnu packages hurd)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
@ -585,13 +586,14 @@ (define actions
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((gnu build activation) '((gnu build activation)
(guix build utils))) (guix build utils)))
(with-extensions (list guile-zlib)
#~(begin #~(begin
(use-modules (gnu build activation) (use-modules (gnu build activation)
(guix build utils)) (guix build utils))
;; Make sure the user accounting database exists. If it ;; Make sure the user accounting database exists. If
;; does not exist, 'setutxent' does not create it and ;; it does not exist, 'setutxent' does not create it
;; thus there is no accounting at all. ;; and thus there is no accounting at all.
(close-port (open-file "/var/run/utmpx" "a0")) (close-port (open-file "/var/run/utmpx" "a0"))
;; Same for 'wtmp', which is populated by mingetty et ;; Same for 'wtmp', which is populated by mingetty et
@ -599,14 +601,14 @@ (define actions
(mkdir-p "/var/log") (mkdir-p "/var/log")
(close-port (open-file "/var/log/wtmp" "a0")) (close-port (open-file "/var/log/wtmp" "a0"))
;; Set up /run/current-system. Among other things this ;; Set up /run/current-system. Among other things
;; sets up locales, which the activation snippets ;; this sets up locales, which the activation snippets
;; executed below may expect. ;; executed below may expect.
(activate-current-system) (activate-current-system)
;; Run the services' activation snippets. ;; Run the services' activation snippets.
;; TODO: Use 'load-compiled'. ;; TODO: Use 'load-compiled'.
(for-each primitive-load '#$actions))))) (for-each primitive-load '#$actions))))))
(define (gexps->activation-gexp gexps) (define (gexps->activation-gexp gexps)
"Return a gexp that runs the activation script containing 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)) #:select (coreutils glibc glibc-utf8-locales))
#:use-module (gnu packages package-management) #:use-module (gnu packages package-management)
#:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) #: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 linux)
#:use-module (gnu packages terminals) #:use-module (gnu packages terminals)
#:use-module ((gnu build file-systems) #: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." to use as the tty. This is primarily useful for headless systems."
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((gnu build linux-boot))) ;for 'find-long-options' '((gnu build linux-boot))) ;for 'find-long-options'
(with-extensions (list guile-zlib)
#~(begin #~(begin
;; console=device,options ;; console=device,options
;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
@ -844,7 +846,8 @@ (define (default-serial-port)
(let* ((not-comma (char-set-complement (char-set #\,))) (let* ((not-comma (char-set-complement (char-set #\,)))
(command (linux-command-line)) (command (linux-command-line))
(agetty-specs (find-long-options "agetty.tty" command)) (agetty-specs (find-long-options "agetty.tty" command))
(console-specs (filter (lambda (spec) (console-specs
(filter (lambda (spec)
(and (string-prefix? "tty" spec) (and (string-prefix? "tty" spec)
(not (or (not (or
(string-prefix? "tty0" spec) (string-prefix? "tty0" spec)
@ -865,7 +868,7 @@ (define (default-serial-port)
;; Extract device name from first spec. ;; Extract device name from first spec.
(match (string-tokenize spec not-comma) (match (string-tokenize spec not-comma)
((device-name _ ...) ((device-name _ ...)
device-name)))))))) device-name)))))))))
(define agetty-shepherd-service (define agetty-shepherd-service
(match-lambda (match-lambda
@ -890,6 +893,7 @@ (define agetty-shepherd-service
(start (start
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((gnu build linux-boot))) '((gnu build linux-boot)))
(with-extensions (list guile-zlib)
#~(lambda args #~(lambda args
(let ((defaulted-tty #$(or tty (default-serial-port)))) (let ((defaulted-tty #$(or tty (default-serial-port))))
(apply (apply
@ -921,10 +925,10 @@ (define agetty-shepherd-service
#$@(if no-clear? #$@(if no-clear?
#~("--noclear") #~("--noclear")
#~()) #~())
;;; FIXME This doesn't work as expected. According to agetty(8), if this option ;;; FIXME This doesn't work as expected. According to agetty(8), if this
;;; is not passed, then the default is 'auto'. However, in my tests, when that ;;; option is not passed, then the default is 'auto'. However, in my tests,
;;; option is selected, agetty never presents the login prompt, and the ;;; when that option is selected, agetty never presents the login prompt, and
;;; term-ttyS0 service respawns every few seconds. ;;; the term-ttyS0 service respawns every few seconds.
#$@(if local-line #$@(if local-line
#~(#$(match local-line #~(#$(match local-line
('auto "--local-line=auto") ('auto "--local-line=auto")
@ -956,7 +960,8 @@ (define agetty-shepherd-service
#~("--keep-baud") #~("--keep-baud")
#~()) #~())
#$@(if timeout #$@(if timeout
#~("--timeout" #$(number->string timeout)) #~("--timeout"
#$(number->string timeout))
#~()) #~())
#$@(if detect-case? #$@(if detect-case?
#~("--detect-case") #~("--detect-case")
@ -1005,7 +1010,7 @@ (define agetty-shepherd-service
#~(#$term) #~(#$term)
#~()))) #~())))
(const #f)) ; never start. (const #f)) ; never start.
args))))) args))))))
(stop #~(make-kill-destructor))))))) (stop #~(make-kill-destructor)))))))
(define agetty-service-type (define agetty-service-type
@ -1939,6 +1944,7 @@ (define udev-shepherd-service
(start (start
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((gnu build linux-boot))) '((gnu build linux-boot)))
(with-extensions (list guile-zlib)
#~(lambda () #~(lambda ()
(define udevd (define udevd
;; 'udevd' from eudev. ;; 'udevd' from eudev.
@ -1978,7 +1984,9 @@ (define (wait-for-udevd)
(make-static-device-nodes directory)) (make-static-device-nodes directory))
(umask old-umask)) (umask old-umask))
(let ((pid (fork+exec-command (list udevd) (let ((pid
(fork+exec-command
(list udevd)
#:environment-variables #:environment-variables
(cons* (cons*
;; The first one is for udev, the second one for ;; The first one is for udev, the second one for
@ -2002,7 +2010,7 @@ (define (wait-for-udevd)
;; Wait for things to settle down. ;; Wait for things to settle down.
(system* #$(file-append udev "/bin/udevadm") (system* #$(file-append udev "/bin/udevadm")
"settle") "settle")
pid)))) pid)))))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
;; When halting the system, 'udev' is actually killed by ;; 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) (match (package-transitive-propagated-inputs package)
(((labels packages) ...) (((labels packages) ...)
packages)))) packages))))
(list guile-gcrypt guile-sqlite3))) (list guile-gcrypt guile-sqlite3 guile-zlib)))
(define-syntax-rule (with-imported-modules* gexp* ...) (define-syntax-rule (with-imported-modules* gexp* ...)
(with-extensions gcrypt-sqlite3&co (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)) (program-file "init" exp #:guile guile))
(define builder (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 (with-imported-modules (source-module-closure
'((gnu build linux-initrd))) '((gnu build linux-initrd)))
#~(begin #~(begin
@ -111,11 +114,16 @@ (define builder
(define (flat-linux-module-directory linux modules) (define (flat-linux-module-directory linux modules)
"Return a flat directory containing the Linux kernel modules listed in "Return a flat directory containing the Linux kernel modules listed in
MODULES and taken from LINUX." MODULES and taken from LINUX."
(define imported-modules
(source-module-closure '((gnu build linux-modules)
(guix build utils))))
(define build-exp (define build-exp
(with-imported-modules (source-module-closure (with-imported-modules imported-modules
'((gnu build linux-modules))) (with-extensions (list guile-zlib)
#~(begin #~(begin
(use-modules (gnu build linux-modules) (use-modules (gnu build linux-modules)
(guix build utils)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-26)) (srfi srfi-26))
@ -126,19 +134,29 @@ (define modules
(let* ((lookup (cut find-module-file module-dir <>)) (let* ((lookup (cut find-module-file module-dir <>))
(modules (map lookup '#$modules))) (modules (map lookup '#$modules)))
(append modules (append modules
(recursive-module-dependencies modules (recursive-module-dependencies
modules
#:lookup-module lookup)))) #: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) (mkdir #$output)
(for-each (lambda (module) (for-each (lambda (module)
(format #t "copying '~a'...~%" module) (let ((out-module
(copy-file module
(string-append #$output "/" (string-append #$output "/"
(basename module)))) (basename module))))
(format #t "copying '~a'...~%" module)
(copy-file module out-module)
(maybe-uncompress out-module)))
(delete-duplicates modules)) (delete-duplicates modules))
;; Hyphen or underscore? This database tells us. ;; Hyphen or underscore? This database tells us.
(write-module-name-database #$output)))) (write-module-name-database #$output)))))
(computed-file "linux-modules" build-exp)) (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) #:use-module ((gnu packages admin)
#:select (shadow)) #:select (shadow))
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages guile)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
@ -324,11 +325,12 @@ (define accounts
(start (with-imported-modules (source-module-closure (start (with-imported-modules (source-module-closure
'((gnu build activation) '((gnu build activation)
(gnu system accounts))) (gnu system accounts)))
(with-extensions (list guile-zlib)
#~(lambda () #~(lambda ()
(activate-user-home (activate-user-home
(map sexp->user-account (map sexp->user-account
(list #$@(map user-account->gexp accounts)))) (list #$@(map user-account->gexp accounts))))
#t))) ;success #t)))) ;success
(documentation "Create user home directories.")))) (documentation "Create user home directories."))))
(define (shells-file shells) (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." This is meant to be used as a profile hook."
(define kmod ; lazy reference (define kmod ; lazy reference
(module-ref (resolve-interface '(gnu packages linux)) 'kmod)) (module-ref (resolve-interface '(gnu packages linux)) 'kmod))
(define guile-zlib
(module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
(define build (define build
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((guix build utils) '((guix build utils)
(gnu build linux-modules))) (gnu build linux-modules)))
(with-extensions (list guile-zlib)
#~(begin #~(begin
(use-modules (ice-9 ftw) (use-modules (ice-9 ftw)
(ice-9 match) (ice-9 match)
@ -1241,7 +1246,7 @@ (define build
;; CONFIG_MODULES=n. ;; CONFIG_MODULES=n.
(mkdir #$output)) (mkdir #$output))
(_ (error "Specified Linux kernel and Linux kernel modules (_ (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 (gexp->derivation "linux-module-database" build
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f