amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00: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
Download patch file Download diff file Expand all files Collapse all files

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

@ -24,6 +24,7 @@
#: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 @@ string list."
(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 @@ key/value pairs.."
(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 @@ modules that can be postloaded, of the soft dependencies of module 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 @@ underscores."
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,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 ;; 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) (string-map (lambda (chr) ;converse of 'normalize-module-name'
(string-map (lambda (chr) ;converse of 'normalize-module-name' (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 @@ not a file name."
(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 @@ are required to access DEVICE."
;;; 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 @@ always work because sometimes underscores in NAME map to hyphens (e.g.,
(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 @@ hyphens vs. underscores."
(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 @@ are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f."
(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 @@ be loaded on-demand, such as file system modules."
(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 @@ selected keymap."
;; 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)

31
gnu/machine/ssh.scm
View file

@ -21,6 +21,7 @@
#: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,22 +249,24 @@ not available in the initrd."
'((gnu build file-systems) '((gnu build file-systems)
(gnu build linux-modules) (gnu build linux-modules)
(gnu system uuid))) (gnu system uuid)))
#~(begin (with-extensions (list guile-zlib)
(use-modules (gnu build file-systems) #~(begin
(gnu build linux-modules) (use-modules (gnu build file-systems)
(gnu system uuid)) (gnu build linux-modules)
(gnu system uuid))
(define dev (define dev
#$(cond ((string? device) device) #$(cond ((string? device) device)
((uuid? device) #~(find-partition-by-uuid ((uuid? device) #~(find-partition-by-uuid
(string->uuid (string->uuid
#$(uuid->string device)))) #$(uuid->string device))))
((file-system-label? device) ((file-system-label? device)
#~(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)

38
gnu/services.scm
View file

@ -35,6 +35,7 @@
#: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,28 +586,29 @@ ACTIVATION-SCRIPT-TYPE."
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((gnu build activation) '((gnu build activation)
(guix build utils))) (guix build utils)))
#~(begin (with-extensions (list guile-zlib)
(use-modules (gnu build activation) #~(begin
(guix build utils)) (use-modules (gnu build activation)
(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
;; al. ;; al.
(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."

416
gnu/services/base.scm
View file

@ -50,6 +50,7 @@
#: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,36 +837,38 @@ the message of the day, among other things."
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'
#~(begin (with-extensions (list guile-zlib)
;; console=device,options #~(begin
;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). ;; console=device,options
;; options: BBBBPNF. P n|o|e, N number of bits, ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
;; F flow control (r RTS) ;; options: BBBBPNF. P n|o|e, N number of bits,
(let* ((not-comma (char-set-complement (char-set #\,))) ;; F flow control (r RTS)
(command (linux-command-line)) (let* ((not-comma (char-set-complement (char-set #\,)))
(agetty-specs (find-long-options "agetty.tty" command)) (command (linux-command-line))
(console-specs (filter (lambda (spec) (agetty-specs (find-long-options "agetty.tty" command))
(and (string-prefix? "tty" spec) (console-specs
(not (or (filter (lambda (spec)
(string-prefix? "tty0" spec) (and (string-prefix? "tty" spec)
(string-prefix? "tty1" spec) (not (or
(string-prefix? "tty2" spec) (string-prefix? "tty0" spec)
(string-prefix? "tty3" spec) (string-prefix? "tty1" spec)
(string-prefix? "tty4" spec) (string-prefix? "tty2" spec)
(string-prefix? "tty5" spec) (string-prefix? "tty3" spec)
(string-prefix? "tty6" spec) (string-prefix? "tty4" spec)
(string-prefix? "tty7" spec) (string-prefix? "tty5" spec)
(string-prefix? "tty8" spec) (string-prefix? "tty6" spec)
(string-prefix? "tty9" spec))))) (string-prefix? "tty7" spec)
(find-long-options "console" command))) (string-prefix? "tty8" spec)
(specs (append agetty-specs console-specs))) (string-prefix? "tty9" spec)))))
(match specs (find-long-options "console" command)))
(() #f) (specs (append agetty-specs console-specs)))
((spec _ ...) (match specs
;; Extract device name from first spec. (() #f)
(match (string-tokenize spec not-comma) ((spec _ ...)
((device-name _ ...) ;; Extract device name from first spec.
device-name)))))))) (match (string-tokenize spec not-comma)
((device-name _ ...)
device-name)))))))))
(define agetty-shepherd-service (define agetty-shepherd-service
(match-lambda (match-lambda
@ -890,122 +893,124 @@ to use as the tty. This is primarily useful for headless systems."
(start (start
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((gnu build linux-boot))) '((gnu build linux-boot)))
#~(lambda args (with-extensions (list guile-zlib)
(let ((defaulted-tty #$(or tty (default-serial-port)))) #~(lambda args
(apply (let ((defaulted-tty #$(or tty (default-serial-port))))
(if defaulted-tty (apply
(make-forkexec-constructor (if defaulted-tty
(list #$(file-append util-linux "/sbin/agetty") (make-forkexec-constructor
#$@extra-options (list #$(file-append util-linux "/sbin/agetty")
#$@(if eight-bits? #$@extra-options
#~("--8bits") #$@(if eight-bits?
#~()) #~("--8bits")
#$@(if no-reset? #~())
#~("--noreset") #$@(if no-reset?
#~()) #~("--noreset")
#$@(if remote? #~())
#~("--remote") #$@(if remote?
#~()) #~("--remote")
#$@(if flow-control? #~())
#~("--flow-control") #$@(if flow-control?
#~()) #~("--flow-control")
#$@(if host #~())
#~("--host" #$host) #$@(if host
#~()) #~("--host" #$host)
#$@(if no-issue? #~())
#~("--noissue") #$@(if no-issue?
#~()) #~("--noissue")
#$@(if init-string #~())
#~("--init-string" #$init-string) #$@(if init-string
#~()) #~("--init-string" #$init-string)
#$@(if no-clear? #~())
#~("--noclear") #$@(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 ;;; FIXME This doesn't work as expected. According to agetty(8), if this
;;; option is selected, agetty never presents the login prompt, and the ;;; option is not passed, then the default is 'auto'. However, in my tests,
;;; term-ttyS0 service respawns every few seconds. ;;; when that option is selected, agetty never presents the login prompt, and
#$@(if local-line ;;; the term-ttyS0 service respawns every few seconds.
#~(#$(match local-line #$@(if local-line
('auto "--local-line=auto") #~(#$(match local-line
('always "--local-line=always") ('auto "--local-line=auto")
('never "-local-line=never"))) ('always "--local-line=always")
#~()) ('never "-local-line=never")))
#$@(if tty #~())
#~() #$@(if tty
#~("--keep-baud")) #~()
#$@(if extract-baud? #~("--keep-baud"))
#~("--extract-baud") #$@(if extract-baud?
#~()) #~("--extract-baud")
#$@(if skip-login? #~())
#~("--skip-login") #$@(if skip-login?
#~()) #~("--skip-login")
#$@(if no-newline? #~())
#~("--nonewline") #$@(if no-newline?
#~()) #~("--nonewline")
#$@(if login-options #~())
#~("--login-options" #$login-options) #$@(if login-options
#~()) #~("--login-options" #$login-options)
#$@(if chroot #~())
#~("--chroot" #$chroot) #$@(if chroot
#~()) #~("--chroot" #$chroot)
#$@(if hangup? #~())
#~("--hangup") #$@(if hangup?
#~()) #~("--hangup")
#$@(if keep-baud? #~())
#~("--keep-baud") #$@(if keep-baud?
#~()) #~("--keep-baud")
#$@(if timeout #~())
#~("--timeout" #$(number->string timeout)) #$@(if timeout
#~()) #~("--timeout"
#$@(if detect-case? #$(number->string timeout))
#~("--detect-case") #~())
#~()) #$@(if detect-case?
#$@(if wait-cr? #~("--detect-case")
#~("--wait-cr") #~())
#~()) #$@(if wait-cr?
#$@(if no-hints? #~("--wait-cr")
#~("--nohints?") #~())
#~()) #$@(if no-hints?
#$@(if no-hostname? #~("--nohints?")
#~("--nohostname") #~())
#~()) #$@(if no-hostname?
#$@(if long-hostname? #~("--nohostname")
#~("--long-hostname") #~())
#~()) #$@(if long-hostname?
#$@(if erase-characters #~("--long-hostname")
#~("--erase-chars" #$erase-characters) #~())
#~()) #$@(if erase-characters
#$@(if kill-characters #~("--erase-chars" #$erase-characters)
#~("--kill-chars" #$kill-characters) #~())
#~()) #$@(if kill-characters
#$@(if chdir #~("--kill-chars" #$kill-characters)
#~("--chdir" #$chdir) #~())
#~()) #$@(if chdir
#$@(if delay #~("--chdir" #$chdir)
#~("--delay" #$(number->string delay)) #~())
#~()) #$@(if delay
#$@(if nice #~("--delay" #$(number->string delay))
#~("--nice" #$(number->string nice)) #~())
#~()) #$@(if nice
#$@(if auto-login #~("--nice" #$(number->string nice))
(list "--autologin" auto-login) #~())
'()) #$@(if auto-login
#$@(if login-program (list "--autologin" auto-login)
#~("--login-program" #$login-program) '())
#~()) #$@(if login-program
#$@(if login-pause? #~("--login-program" #$login-program)
#~("--login-pause") #~())
#~()) #$@(if login-pause?
defaulted-tty #~("--login-pause")
#$@(if baud-rate #~())
#~(#$baud-rate) defaulted-tty
#~()) #$@(if baud-rate
#$@(if term #~(#$baud-rate)
#~(#$term) #~())
#~()))) #$@(if term
(const #f)) ; never start. #~(#$term)
args))))) #~())))
(const #f)) ; never start.
args))))))
(stop #~(make-kill-destructor))))))) (stop #~(make-kill-destructor)))))))
(define agetty-service-type (define agetty-service-type
@ -1939,70 +1944,73 @@ item of @var{packages}."
(start (start
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((gnu build linux-boot))) '((gnu build linux-boot)))
#~(lambda () (with-extensions (list guile-zlib)
(define udevd #~(lambda ()
;; 'udevd' from eudev. (define udevd
#$(file-append udev "/sbin/udevd")) ;; 'udevd' from eudev.
#$(file-append udev "/sbin/udevd"))
(define (wait-for-udevd) (define (wait-for-udevd)
;; Wait until someone's listening on udevd's control ;; Wait until someone's listening on udevd's control
;; socket. ;; socket.
(let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
(let try () (let try ()
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(connect sock PF_UNIX "/run/udev/control") (connect sock PF_UNIX "/run/udev/control")
(close-port sock)) (close-port sock))
(lambda args (lambda args
(format #t "waiting for udevd...~%") (format #t "waiting for udevd...~%")
(usleep 500000) (usleep 500000)
(try)))))) (try))))))
;; Allow udev to find the modules. ;; Allow udev to find the modules.
(setenv "LINUX_MODULE_DIRECTORY" (setenv "LINUX_MODULE_DIRECTORY"
"/run/booted-system/kernel/lib/modules") "/run/booted-system/kernel/lib/modules")
(let* ((kernel-release (let* ((kernel-release
(utsname:release (uname))) (utsname:release (uname)))
(linux-module-directory (linux-module-directory
(getenv "LINUX_MODULE_DIRECTORY")) (getenv "LINUX_MODULE_DIRECTORY"))
(directory (directory
(string-append linux-module-directory "/" (string-append linux-module-directory "/"
kernel-release)) kernel-release))
(old-umask (umask #o022))) (old-umask (umask #o022)))
;; If we're in a container, DIRECTORY might not exist, ;; If we're in a container, DIRECTORY might not exist,
;; for instance because the host runs a different ;; for instance because the host runs a different
;; kernel. In that case, skip it; we'll just miss a few ;; kernel. In that case, skip it; we'll just miss a few
;; nodes like /dev/fuse. ;; nodes like /dev/fuse.
(when (file-exists? directory) (when (file-exists? directory)
(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
#:environment-variables (fork+exec-command
(cons* (list udevd)
;; The first one is for udev, the second one for #:environment-variables
;; eudev. (cons*
(string-append "UDEV_CONFIG_FILE=" #$udev.conf) ;; The first one is for udev, the second one for
(string-append "EUDEV_RULES_DIRECTORY=" ;; eudev.
#$(file-append (string-append "UDEV_CONFIG_FILE=" #$udev.conf)
rules "/lib/udev/rules.d")) (string-append "EUDEV_RULES_DIRECTORY="
(string-append "LINUX_MODULE_DIRECTORY=" #$(file-append
(getenv "LINUX_MODULE_DIRECTORY")) rules "/lib/udev/rules.d"))
(default-environment-variables))))) (string-append "LINUX_MODULE_DIRECTORY="
;; Wait until udevd is up and running. This appears to (getenv "LINUX_MODULE_DIRECTORY"))
;; be needed so that the events triggered below are (default-environment-variables)))))
;; actually handled. ;; Wait until udevd is up and running. This appears to
(wait-for-udevd) ;; be needed so that the events triggered below are
;; actually handled.
(wait-for-udevd)
;; Trigger device node creation. ;; Trigger device node creation.
(system* #$(file-append udev "/bin/udevadm") (system* #$(file-append udev "/bin/udevadm")
"trigger" "--action=add") "trigger" "--action=add")
;; 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 @@
(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

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

@ -77,6 +77,9 @@ the derivations referenced by EXP are automatically copied to the initrd."
(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,34 +114,49 @@ the derivations referenced by EXP are automatically copied to the initrd."
(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)
(srfi srfi-1) (guix build utils)
(srfi srfi-26)) (srfi srfi-1)
(srfi srfi-26))
(define module-dir (define module-dir
(string-append #$linux "/lib/modules")) (string-append #$linux "/lib/modules"))
(define modules (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
#:lookup-module lookup)))) modules
#:lookup-module lookup))))
(mkdir #$output) (define (maybe-uncompress file)
(for-each (lambda (module) ;; If FILE is a compressed module, uncompress it, as the initrd
(format #t "copying '~a'...~%" module) ;; is already gzipped as a whole.
(copy-file module (cond
(string-append #$output "/" ((string-contains file ".ko.gz")
(basename module)))) (invoke #+(file-append gzip "/bin/gunzip") file))))
(delete-duplicates modules))
;; Hyphen or underscore? This database tells us. (mkdir #$output)
(write-module-name-database #$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)) (computed-file "linux-modules" build-exp))

12
gnu/system/shadow.scm
View file

@ -34,6 +34,7 @@
#: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 @@ accounts among ACCOUNTS+GROUPS."
(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)))
#~(lambda () (with-extensions (list guile-zlib)
(activate-user-home #~(lambda ()
(map sexp->user-account (activate-user-home
(list #$@(map user-account->gexp accounts)))) (map sexp->user-account
#t))) ;success (list #$@(map user-account->gexp accounts))))
#t)))) ;success
(documentation "Create user home directories.")))) (documentation "Create user home directories."))))
(define (shells-file shells) (define (shells-file shells)

69
guix/profiles.scm
View file

@ -1205,43 +1205,48 @@ and creates the dependency graph of all these kernel modules.
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)))
#~(begin (with-extensions (list guile-zlib)
(use-modules (ice-9 ftw) #~(begin
(ice-9 match) (use-modules (ice-9 ftw)
(srfi srfi-1) ; append-map (ice-9 match)
(gnu build linux-modules)) (srfi srfi-1) ; append-map
(gnu build linux-modules))
(let* ((inputs '#$(manifest-inputs manifest)) (let* ((inputs '#$(manifest-inputs manifest))
(module-directories (module-directories
(map (lambda (directory) (map (lambda (directory)
(string-append directory "/lib/modules")) (string-append directory "/lib/modules"))
inputs)) inputs))
(directory-entries (directory-entries
(lambda (directory) (lambda (directory)
(or (scandir directory (or (scandir directory
(lambda (basename) (lambda (basename)
(not (string-prefix? "." basename)))) (not (string-prefix? "." basename))))
'()))) '())))
;; Note: Should usually result in one entry. ;; Note: Should usually result in one entry.
(versions (delete-duplicates (versions (delete-duplicates
(append-map directory-entries (append-map directory-entries
module-directories)))) module-directories))))
(match versions (match versions
((version) ((version)
(let ((old-path (getenv "PATH"))) (let ((old-path (getenv "PATH")))
(setenv "PATH" #+(file-append kmod "/bin")) (setenv "PATH" #+(file-append kmod "/bin"))
(make-linux-module-directory inputs version #$output) (make-linux-module-directory inputs version #$output)
(setenv "PATH" old-path))) (setenv "PATH" old-path)))
(() (()
;; Nothing here, maybe because this is a kernel with ;; Nothing here, maybe because this is a kernel with
;; 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