[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/02: linux-libre: Support module compression.
|
From: |
guix-commits |
|
Subject: |
01/02: linux-libre: Support module compression. |
|
Date: |
Tue, 25 Aug 2020 06:23:19 -0400 (EDT) |
mothacehe pushed a commit to branch master
in repository guix.
commit 755f365b02b42a5d1e8ef3000dadef069553a478
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sun Jul 5 12:23:21 2020 +0200
linux-libre: Support module compression.
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.
---
gnu/build/linux-modules.scm | 115 ++++++++----
gnu/installer.scm | 3 +-
gnu/machine/ssh.scm | 35 ++--
gnu/services.scm | 46 ++---
gnu/services/base.scm | 428 ++++++++++++++++++++++----------------------
gnu/system/image.scm | 2 +-
gnu/system/linux-initrd.scm | 72 +++++---
gnu/system/shadow.scm | 12 +-
guix/profiles.scm | 71 ++++----
9 files changed, 433 insertions(+), 351 deletions(-)
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index aa1c7cf..3a47322 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -24,6 +24,7 @@
#: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 @@ string list."
(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 @@ key/value pairs.."
(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 @@ modules that can be postloaded, of the soft dependencies
of module FILE."
(_ #f))
(modinfo-section-contents file))))
-(define dot-ko
- (cut string-append <> ".ko"))
-
-(define (ensure-dot-ko name)
- "Return NAME with a '.ko' prefix appended, unless it already has it."
- (if (string-suffix? ".ko" name)
+(define (strip-extension filename)
+ (let ((extension (string-index filename #\.)))
+ (if extension
+ (string-take filename extension)
+ filename)))
+
+(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 @@ underscores."
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,19 +238,19 @@ whereas file names often, but not always, use hyphens.
Examples:
;; 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)
- (string-map (lambda (chr) ;converse of 'normalize-module-name'
- (case chr
- ((#\_) #\-)
- (else chr)))
- module)))))
+ (delete-duplicates
+ (list module
+ (normalize-module-name module)
+ (string-map (lambda (chr) ;converse of 'normalize-module-name'
+ (case chr
+ ((#\_) #\-)
+ (else chr)))
+ module))))
(match (find-files directory
(lambda (file stat)
- (member (basename file) names)))
+ (member (strip-extension
+ (basename file)) names)))
((file)
file)
(()
@@ -290,8 +320,8 @@ not a file name."
(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 @@ are required to access DEVICE."
;;; 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 @@ always work because sometimes underscores in NAME map to
hyphens (e.g.,
(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 @@ hyphens vs. underscores."
(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 @@ are found, return a tuple (DEVNAME TYPE MAJOR MINOR),
otherwise return #f."
(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 @@ be loaded on-demand, such as file system modules."
(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)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 5c3192d..576ac90 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -342,7 +342,8 @@ selected keymap."
;; 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)
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 4e31baa..ee5032e 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -21,6 +21,7 @@
#: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,22 +249,24 @@ not available in the initrd."
'((gnu build file-systems)
(gnu build linux-modules)
(gnu system uuid)))
- #~(begin
- (use-modules (gnu build file-systems)
- (gnu build linux-modules)
- (gnu system uuid))
-
- (define dev
- #$(cond ((string? device) device)
- ((uuid? device) #~(find-partition-by-uuid
- (string->uuid
- #$(uuid->string device))))
- ((file-system-label? device)
- #~(find-partition-by-label
- #$(file-system-label->string device)))))
-
- (missing-modules dev '#$(operating-system-initrd-modules
- (machine-operating-system machine)))))))
+ (with-extensions (list guile-zlib)
+ #~(begin
+ (use-modules (gnu build file-systems)
+ (gnu build linux-modules)
+ (gnu system uuid))
+
+ (define dev
+ #$(cond ((string? device) device)
+ ((uuid? device) #~(find-partition-by-uuid
+ (string->uuid
+ #$(uuid->string device))))
+ ((file-system-label? device)
+ #~(find-partition-by-label
+ #$(file-system-label->string device)))))
+
+ (missing-modules dev
+ '#$(operating-system-initrd-modules
+ (machine-operating-system machine))))))))
(remote-let ((missing remote-exp))
(unless (null? missing)
diff --git a/gnu/services.scm b/gnu/services.scm
index 11ba21e..3e59c64 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -35,6 +35,7 @@
#: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,28 +586,29 @@ ACTIVATION-SCRIPT-TYPE."
(with-imported-modules (source-module-closure
'((gnu build activation)
(guix build utils)))
- #~(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.
- (close-port (open-file "/var/run/utmpx" "a0"))
-
- ;; Same for 'wtmp', which is populated by mingetty et
- ;; al.
- (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
- ;; executed below may expect.
- (activate-current-system)
-
- ;; Run the services' activation snippets.
- ;; TODO: Use 'load-compiled'.
- (for-each primitive-load '#$actions)))))
+ (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.
+ (close-port (open-file "/var/run/utmpx" "a0"))
+
+ ;; Same for 'wtmp', which is populated by mingetty et
+ ;; al.
+ (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
+ ;; executed below may expect.
+ (activate-current-system)
+
+ ;; Run the services' activation snippets.
+ ;; TODO: Use 'load-compiled'.
+ (for-each primitive-load '#$actions))))))
(define (gexps->activation-gexp gexps)
"Return a gexp that runs the activation script containing GEXPS."
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 491f357..966e7fe 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -50,6 +50,7 @@
#: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,36 +837,38 @@ the message of the day, among other things."
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'
- #~(begin
- ;; console=device,options
- ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
- ;; options: BBBBPNF. P n|o|e, N number of bits,
- ;; F flow control (r RTS)
- (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)
- (and (string-prefix? "tty" spec)
- (not (or
- (string-prefix? "tty0" spec)
- (string-prefix? "tty1" spec)
- (string-prefix? "tty2" spec)
- (string-prefix? "tty3" spec)
- (string-prefix? "tty4" spec)
- (string-prefix? "tty5" spec)
- (string-prefix? "tty6" spec)
- (string-prefix? "tty7" spec)
- (string-prefix? "tty8" spec)
- (string-prefix? "tty9"
spec)))))
- (find-long-options "console" command)))
- (specs (append agetty-specs console-specs)))
- (match specs
- (() #f)
- ((spec _ ...)
- ;; Extract device name from first spec.
- (match (string-tokenize spec not-comma)
- ((device-name _ ...)
- device-name))))))))
+ (with-extensions (list guile-zlib)
+ #~(begin
+ ;; console=device,options
+ ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
+ ;; options: BBBBPNF. P n|o|e, N number of bits,
+ ;; F flow control (r RTS)
+ (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)
+ (and (string-prefix? "tty" spec)
+ (not (or
+ (string-prefix? "tty0" spec)
+ (string-prefix? "tty1" spec)
+ (string-prefix? "tty2" spec)
+ (string-prefix? "tty3" spec)
+ (string-prefix? "tty4" spec)
+ (string-prefix? "tty5" spec)
+ (string-prefix? "tty6" spec)
+ (string-prefix? "tty7" spec)
+ (string-prefix? "tty8" spec)
+ (string-prefix? "tty9" spec)))))
+ (find-long-options "console" command)))
+ (specs (append agetty-specs console-specs)))
+ (match specs
+ (() #f)
+ ((spec _ ...)
+ ;; Extract device name from first spec.
+ (match (string-tokenize spec not-comma)
+ ((device-name _ ...)
+ device-name)))))))))
(define agetty-shepherd-service
(match-lambda
@@ -890,122 +893,124 @@ to use as the tty. This is primarily useful for
headless systems."
(start
(with-imported-modules (source-module-closure
'((gnu build linux-boot)))
- #~(lambda args
- (let ((defaulted-tty #$(or tty (default-serial-port))))
- (apply
- (if defaulted-tty
- (make-forkexec-constructor
- (list #$(file-append util-linux "/sbin/agetty")
- #$@extra-options
- #$@(if eight-bits?
- #~("--8bits")
- #~())
- #$@(if no-reset?
- #~("--noreset")
- #~())
- #$@(if remote?
- #~("--remote")
- #~())
- #$@(if flow-control?
- #~("--flow-control")
- #~())
- #$@(if host
- #~("--host" #$host)
- #~())
- #$@(if no-issue?
- #~("--noissue")
- #~())
- #$@(if init-string
- #~("--init-string" #$init-string)
- #~())
- #$@(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.
- #$@(if local-line
- #~(#$(match local-line
- ('auto "--local-line=auto")
- ('always "--local-line=always")
- ('never "-local-line=never")))
- #~())
- #$@(if tty
- #~()
- #~("--keep-baud"))
- #$@(if extract-baud?
- #~("--extract-baud")
- #~())
- #$@(if skip-login?
- #~("--skip-login")
- #~())
- #$@(if no-newline?
- #~("--nonewline")
- #~())
- #$@(if login-options
- #~("--login-options" #$login-options)
- #~())
- #$@(if chroot
- #~("--chroot" #$chroot)
- #~())
- #$@(if hangup?
- #~("--hangup")
- #~())
- #$@(if keep-baud?
- #~("--keep-baud")
- #~())
- #$@(if timeout
- #~("--timeout" #$(number->string timeout))
- #~())
- #$@(if detect-case?
- #~("--detect-case")
- #~())
- #$@(if wait-cr?
- #~("--wait-cr")
- #~())
- #$@(if no-hints?
- #~("--nohints?")
- #~())
- #$@(if no-hostname?
- #~("--nohostname")
- #~())
- #$@(if long-hostname?
- #~("--long-hostname")
- #~())
- #$@(if erase-characters
- #~("--erase-chars" #$erase-characters)
- #~())
- #$@(if kill-characters
- #~("--kill-chars" #$kill-characters)
- #~())
- #$@(if chdir
- #~("--chdir" #$chdir)
- #~())
- #$@(if delay
- #~("--delay" #$(number->string delay))
- #~())
- #$@(if nice
- #~("--nice" #$(number->string nice))
- #~())
- #$@(if auto-login
- (list "--autologin" auto-login)
- '())
- #$@(if login-program
- #~("--login-program" #$login-program)
- #~())
- #$@(if login-pause?
- #~("--login-pause")
- #~())
- defaulted-tty
- #$@(if baud-rate
- #~(#$baud-rate)
- #~())
- #$@(if term
- #~(#$term)
- #~())))
- (const #f)) ; never start.
- args)))))
+ (with-extensions (list guile-zlib)
+ #~(lambda args
+ (let ((defaulted-tty #$(or tty (default-serial-port))))
+ (apply
+ (if defaulted-tty
+ (make-forkexec-constructor
+ (list #$(file-append util-linux "/sbin/agetty")
+ #$@extra-options
+ #$@(if eight-bits?
+ #~("--8bits")
+ #~())
+ #$@(if no-reset?
+ #~("--noreset")
+ #~())
+ #$@(if remote?
+ #~("--remote")
+ #~())
+ #$@(if flow-control?
+ #~("--flow-control")
+ #~())
+ #$@(if host
+ #~("--host" #$host)
+ #~())
+ #$@(if no-issue?
+ #~("--noissue")
+ #~())
+ #$@(if init-string
+ #~("--init-string" #$init-string)
+ #~())
+ #$@(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.
+ #$@(if local-line
+ #~(#$(match local-line
+ ('auto "--local-line=auto")
+ ('always "--local-line=always")
+ ('never "-local-line=never")))
+ #~())
+ #$@(if tty
+ #~()
+ #~("--keep-baud"))
+ #$@(if extract-baud?
+ #~("--extract-baud")
+ #~())
+ #$@(if skip-login?
+ #~("--skip-login")
+ #~())
+ #$@(if no-newline?
+ #~("--nonewline")
+ #~())
+ #$@(if login-options
+ #~("--login-options" #$login-options)
+ #~())
+ #$@(if chroot
+ #~("--chroot" #$chroot)
+ #~())
+ #$@(if hangup?
+ #~("--hangup")
+ #~())
+ #$@(if keep-baud?
+ #~("--keep-baud")
+ #~())
+ #$@(if timeout
+ #~("--timeout"
+ #$(number->string timeout))
+ #~())
+ #$@(if detect-case?
+ #~("--detect-case")
+ #~())
+ #$@(if wait-cr?
+ #~("--wait-cr")
+ #~())
+ #$@(if no-hints?
+ #~("--nohints?")
+ #~())
+ #$@(if no-hostname?
+ #~("--nohostname")
+ #~())
+ #$@(if long-hostname?
+ #~("--long-hostname")
+ #~())
+ #$@(if erase-characters
+ #~("--erase-chars" #$erase-characters)
+ #~())
+ #$@(if kill-characters
+ #~("--kill-chars" #$kill-characters)
+ #~())
+ #$@(if chdir
+ #~("--chdir" #$chdir)
+ #~())
+ #$@(if delay
+ #~("--delay" #$(number->string delay))
+ #~())
+ #$@(if nice
+ #~("--nice" #$(number->string nice))
+ #~())
+ #$@(if auto-login
+ (list "--autologin" auto-login)
+ '())
+ #$@(if login-program
+ #~("--login-program" #$login-program)
+ #~())
+ #$@(if login-pause?
+ #~("--login-pause")
+ #~())
+ defaulted-tty
+ #$@(if baud-rate
+ #~(#$baud-rate)
+ #~())
+ #$@(if term
+ #~(#$term)
+ #~())))
+ (const #f)) ; never start.
+ args))))))
(stop #~(make-kill-destructor)))))))
(define agetty-service-type
@@ -1939,70 +1944,73 @@ item of @var{packages}."
(start
(with-imported-modules (source-module-closure
'((gnu build linux-boot)))
- #~(lambda ()
- (define udevd
- ;; 'udevd' from eudev.
- #$(file-append udev "/sbin/udevd"))
-
- (define (wait-for-udevd)
- ;; Wait until someone's listening on udevd's control
- ;; socket.
- (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
- (let try ()
- (catch 'system-error
- (lambda ()
- (connect sock PF_UNIX "/run/udev/control")
- (close-port sock))
- (lambda args
- (format #t "waiting for udevd...~%")
- (usleep 500000)
- (try))))))
-
- ;; Allow udev to find the modules.
- (setenv "LINUX_MODULE_DIRECTORY"
- "/run/booted-system/kernel/lib/modules")
-
- (let* ((kernel-release
- (utsname:release (uname)))
- (linux-module-directory
- (getenv "LINUX_MODULE_DIRECTORY"))
- (directory
- (string-append linux-module-directory "/"
- kernel-release))
- (old-umask (umask #o022)))
- ;; If we're in a container, DIRECTORY might not exist,
- ;; for instance because the host runs a different
- ;; kernel. In that case, skip it; we'll just miss a few
- ;; nodes like /dev/fuse.
- (when (file-exists? directory)
- (make-static-device-nodes directory))
- (umask old-umask))
-
- (let ((pid (fork+exec-command (list udevd)
- #:environment-variables
- (cons*
- ;; The first one is for udev, the second one for
- ;; eudev.
- (string-append "UDEV_CONFIG_FILE=" #$udev.conf)
- (string-append "EUDEV_RULES_DIRECTORY="
- #$(file-append
- rules "/lib/udev/rules.d"))
- (string-append "LINUX_MODULE_DIRECTORY="
- (getenv "LINUX_MODULE_DIRECTORY"))
- (default-environment-variables)))))
- ;; Wait until udevd is up and running. This appears to
- ;; be needed so that the events triggered below are
- ;; actually handled.
- (wait-for-udevd)
-
- ;; Trigger device node creation.
- (system* #$(file-append udev "/bin/udevadm")
- "trigger" "--action=add")
-
- ;; Wait for things to settle down.
- (system* #$(file-append udev "/bin/udevadm")
- "settle")
- pid))))
+ (with-extensions (list guile-zlib)
+ #~(lambda ()
+ (define udevd
+ ;; 'udevd' from eudev.
+ #$(file-append udev "/sbin/udevd"))
+
+ (define (wait-for-udevd)
+ ;; Wait until someone's listening on udevd's control
+ ;; socket.
+ (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ (connect sock PF_UNIX "/run/udev/control")
+ (close-port sock))
+ (lambda args
+ (format #t "waiting for udevd...~%")
+ (usleep 500000)
+ (try))))))
+
+ ;; Allow udev to find the modules.
+ (setenv "LINUX_MODULE_DIRECTORY"
+ "/run/booted-system/kernel/lib/modules")
+
+ (let* ((kernel-release
+ (utsname:release (uname)))
+ (linux-module-directory
+ (getenv "LINUX_MODULE_DIRECTORY"))
+ (directory
+ (string-append linux-module-directory "/"
+ kernel-release))
+ (old-umask (umask #o022)))
+ ;; If we're in a container, DIRECTORY might not exist,
+ ;; for instance because the host runs a different
+ ;; kernel. In that case, skip it; we'll just miss a few
+ ;; nodes like /dev/fuse.
+ (when (file-exists? directory)
+ (make-static-device-nodes directory))
+ (umask old-umask))
+
+ (let ((pid
+ (fork+exec-command
+ (list udevd)
+ #:environment-variables
+ (cons*
+ ;; The first one is for udev, the second one for
+ ;; eudev.
+ (string-append "UDEV_CONFIG_FILE=" #$udev.conf)
+ (string-append "EUDEV_RULES_DIRECTORY="
+ #$(file-append
+ rules "/lib/udev/rules.d"))
+ (string-append "LINUX_MODULE_DIRECTORY="
+ (getenv "LINUX_MODULE_DIRECTORY"))
+ (default-environment-variables)))))
+ ;; Wait until udevd is up and running. This appears to
+ ;; be needed so that the events triggered below are
+ ;; actually handled.
+ (wait-for-udevd)
+
+ ;; Trigger device node creation.
+ (system* #$(file-append udev "/bin/udevadm")
+ "trigger" "--action=add")
+
+ ;; Wait for things to settle down.
+ (system* #$(file-append udev "/bin/udevadm")
+ "settle")
+ pid)))))
(stop #~(make-kill-destructor))
;; When halting the system, 'udev' is actually killed by
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 36f56e2..19c99a3 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -141,7 +141,7 @@
(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
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 0971ec2..b8a30c0 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -77,6 +77,9 @@ the derivations referenced by EXP are automatically copied to
the initrd."
(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,34 +114,49 @@ the derivations referenced by EXP are automatically
copied to the initrd."
(define (flat-linux-module-directory linux modules)
"Return a flat directory containing the Linux kernel modules listed in
MODULES and taken from LINUX."
- (define build-exp
- (with-imported-modules (source-module-closure
- '((gnu build linux-modules)))
- #~(begin
- (use-modules (gnu build linux-modules)
- (srfi srfi-1)
- (srfi srfi-26))
-
- (define module-dir
- (string-append #$linux "/lib/modules"))
+ (define imported-modules
+ (source-module-closure '((gnu build linux-modules)
+ (guix build utils))))
- (define modules
- (let* ((lookup (cut find-module-file module-dir <>))
- (modules (map lookup '#$modules)))
- (append modules
- (recursive-module-dependencies modules
- #:lookup-module lookup))))
-
- (mkdir #$output)
- (for-each (lambda (module)
- (format #t "copying '~a'...~%" module)
- (copy-file module
- (string-append #$output "/"
- (basename module))))
- (delete-duplicates modules))
-
- ;; Hyphen or underscore? This database tells us.
- (write-module-name-database #$output))))
+ (define build-exp
+ (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))
+
+ (define module-dir
+ (string-append #$linux "/lib/modules"))
+
+ (define modules
+ (let* ((lookup (cut find-module-file module-dir <>))
+ (modules (map lookup '#$modules)))
+ (append 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)
+ (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)))))
(computed-file "linux-modules" build-exp))
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index a69339b..f642d25 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -34,6 +34,7 @@
#: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 @@ accounts among ACCOUNTS+GROUPS."
(start (with-imported-modules (source-module-closure
'((gnu build activation)
(gnu system accounts)))
- #~(lambda ()
- (activate-user-home
- (map sexp->user-account
- (list #$@(map user-account->gexp accounts))))
- #t))) ;success
+ (with-extensions (list guile-zlib)
+ #~(lambda ()
+ (activate-user-home
+ (map sexp->user-account
+ (list #$@(map user-account->gexp accounts))))
+ #t)))) ;success
(documentation "Create user home directories."))))
(define (shells-file shells)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 6b23442..856a05e 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1205,43 +1205,48 @@ and creates the dependency graph of all these kernel
modules.
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)))
- #~(begin
- (use-modules (ice-9 ftw)
- (ice-9 match)
- (srfi srfi-1) ; append-map
- (gnu build linux-modules))
-
- (let* ((inputs '#$(manifest-inputs manifest))
- (module-directories
- (map (lambda (directory)
- (string-append directory "/lib/modules"))
- inputs))
- (directory-entries
- (lambda (directory)
- (or (scandir directory
- (lambda (basename)
- (not (string-prefix? "." basename))))
- '())))
- ;; Note: Should usually result in one entry.
- (versions (delete-duplicates
- (append-map directory-entries
- module-directories))))
- (match versions
- ((version)
- (let ((old-path (getenv "PATH")))
- (setenv "PATH" #+(file-append kmod "/bin"))
- (make-linux-module-directory inputs version #$output)
- (setenv "PATH" old-path)))
- (()
- ;; Nothing here, maybe because this is a kernel with
- ;; CONFIG_MODULES=n.
- (mkdir #$output))
- (_ (error "Specified Linux kernel and Linux kernel modules
-are not all of the same version")))))))
+ (with-extensions (list guile-zlib)
+ #~(begin
+ (use-modules (ice-9 ftw)
+ (ice-9 match)
+ (srfi srfi-1) ; append-map
+ (gnu build linux-modules))
+
+ (let* ((inputs '#$(manifest-inputs manifest))
+ (module-directories
+ (map (lambda (directory)
+ (string-append directory "/lib/modules"))
+ inputs))
+ (directory-entries
+ (lambda (directory)
+ (or (scandir directory
+ (lambda (basename)
+ (not (string-prefix? "." basename))))
+ '())))
+ ;; Note: Should usually result in one entry.
+ (versions (delete-duplicates
+ (append-map directory-entries
+ module-directories))))
+ (match versions
+ ((version)
+ (let ((old-path (getenv "PATH")))
+ (setenv "PATH" #+(file-append kmod "/bin"))
+ (make-linux-module-directory inputs version #$output)
+ (setenv "PATH" old-path)))
+ (()
+ ;; Nothing here, maybe because this is a kernel with
+ ;; CONFIG_MODULES=n.
+ (mkdir #$output))
+ (_ (error "Specified Linux kernel and Linux kernel modules
+are not all of the same version"))))))))
(gexp->derivation "linux-module-database" build
#:local-build? #t
#:substitutable? #f