mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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.
This commit is contained in:
Mathieu Othacehe
parent
46ef674b34
commit
755f365b02
9 changed files with 415 additions and 333 deletions
|
|
@ -24,6 +24,7 @@ (define-module (gnu build linux-modules)
|
|||
#:use-module (guix build syscalls)
|
||||
#:use-module ((guix build utils) #:select (find-files invoke))
|
||||
#:use-module (guix build union)
|
||||
#:autoload (zlib) (call-with-gzip-input-port)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (srfi srfi-1)
|
||||
|
|
@ -94,10 +95,28 @@ (define (key=value->pair str)
|
|||
(cons (string->symbol (string-take str =))
|
||||
(string-drop str (+ 1 =)))))
|
||||
|
||||
;; Matches kernel modules, without compression, with GZIP compression or with
|
||||
;; XZ compression.
|
||||
(define module-regex "\\.ko(\\.gz|\\.xz)?$")
|
||||
|
||||
(define (modinfo-section-contents file)
|
||||
"Return the contents of the '.modinfo' section of FILE as a list of
|
||||
key/value pairs.."
|
||||
(let* ((bv (call-with-input-file file get-bytevector-all))
|
||||
(define (get-bytevector file)
|
||||
(cond
|
||||
((string-suffix? ".ko.gz" file)
|
||||
(let ((port (open-file file "r0")))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
#t)
|
||||
(lambda ()
|
||||
(call-with-gzip-input-port port get-bytevector-all))
|
||||
(lambda ()
|
||||
(close-port port)))))
|
||||
(else
|
||||
(call-with-input-file file get-bytevector-all))))
|
||||
|
||||
(let* ((bv (get-bytevector file))
|
||||
(elf (parse-elf bv))
|
||||
(section (elf-section-by-name elf ".modinfo"))
|
||||
(modinfo (section-contents elf section)))
|
||||
|
|
@ -110,7 +129,7 @@ (define %not-comma
|
|||
(define (module-formal-name file)
|
||||
"Return the module name of FILE as it appears in its info section. Usually
|
||||
the module name is the same as the base name of FILE, modulo hyphens and minus
|
||||
the \".ko\" extension."
|
||||
the \".ko[.gz|.xz]\" extension."
|
||||
(match (assq 'name (modinfo-section-contents file))
|
||||
(('name . name) name)
|
||||
(#f #f)))
|
||||
|
|
@ -171,14 +190,25 @@ (define (module-aliases file)
|
|||
(_ #f))
|
||||
(modinfo-section-contents file))))
|
||||
|
||||
(define dot-ko
|
||||
(cut string-append <> ".ko"))
|
||||
(define (strip-extension filename)
|
||||
(let ((extension (string-index filename #\.)))
|
||||
(if extension
|
||||
(string-take filename extension)
|
||||
filename)))
|
||||
|
||||
(define (ensure-dot-ko name)
|
||||
"Return NAME with a '.ko' prefix appended, unless it already has it."
|
||||
(if (string-suffix? ".ko" name)
|
||||
(define (dot-ko name compression)
|
||||
(let ((suffix (match compression
|
||||
('xz ".ko.xz")
|
||||
('gzip ".ko.gz")
|
||||
(else ".ko"))))
|
||||
(string-append name suffix)))
|
||||
|
||||
(define (ensure-dot-ko name compression)
|
||||
"Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has
|
||||
it."
|
||||
(if (string-contains name ".ko")
|
||||
name
|
||||
(dot-ko name)))
|
||||
(dot-ko name compression)))
|
||||
|
||||
(define (normalize-module-name module)
|
||||
"Return the \"canonical\" name for MODULE, replacing hyphens with
|
||||
|
|
@ -191,9 +221,9 @@ (define (normalize-module-name module)
|
|||
module))
|
||||
|
||||
(define (file-name->module-name file)
|
||||
"Return the module name corresponding to FILE, stripping the trailing '.ko'
|
||||
and normalizing it."
|
||||
(normalize-module-name (basename file ".ko")))
|
||||
"Return the module name corresponding to FILE, stripping the trailing
|
||||
'.ko[.gz|.xz]' and normalizing it."
|
||||
(normalize-module-name (strip-extension (basename file))))
|
||||
|
||||
(define (find-module-file directory module)
|
||||
"Lookup module NAME under DIRECTORY, and return its absolute file name.
|
||||
|
|
@ -208,19 +238,19 @@ (define names
|
|||
;; List of possible file names. XXX: It would of course be cleaner to
|
||||
;; have a database that maps module names to file names and vice versa,
|
||||
;; but everyone seems to be doing hacks like this one. Oh well!
|
||||
(map ensure-dot-ko
|
||||
(delete-duplicates
|
||||
(list module
|
||||
(normalize-module-name module)
|
||||
(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 @@ (define* (load-linux-module* file
|
|||
(recursive? #t)
|
||||
(lookup-module dot-ko)
|
||||
(black-list (module-black-list)))
|
||||
"Load Linux module from FILE, the name of a '.ko' file; return true on
|
||||
success, false otherwise. When RECURSIVE? is true, load its dependencies
|
||||
"Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true
|
||||
on success, false otherwise. When RECURSIVE? is true, load its dependencies
|
||||
first (à la 'modprobe'.) The actual files containing modules depended on are
|
||||
obtained by calling LOOKUP-MODULE with the module name. Modules whose name
|
||||
appears in BLACK-LIST are not loaded."
|
||||
|
|
@ -523,16 +553,29 @@ (define aliases
|
|||
;;; Module databases.
|
||||
;;;
|
||||
|
||||
(define (module-name->file-name/guess directory name)
|
||||
(define* (module-name->file-name/guess directory name
|
||||
#:key compression)
|
||||
"Guess the file name corresponding to NAME, a module name. That doesn't
|
||||
always work because sometimes underscores in NAME map to hyphens (e.g.,
|
||||
\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\")."
|
||||
(string-append directory "/" (ensure-dot-ko name)))
|
||||
\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\"). If the module is
|
||||
compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the
|
||||
compression type."
|
||||
(string-append directory "/" (ensure-dot-ko name compression)))
|
||||
|
||||
(define (module-name-lookup directory)
|
||||
"Return a one argument procedure that takes a module name (e.g.,
|
||||
\"input_leds\") and returns its absolute file name (e.g.,
|
||||
\"/.../input-leds.ko\")."
|
||||
(define (guess-file-name name)
|
||||
(let ((names (list
|
||||
(module-name->file-name/guess directory name)
|
||||
(module-name->file-name/guess directory name
|
||||
#:compression 'xz)
|
||||
(module-name->file-name/guess directory name
|
||||
#:compression 'gzip))))
|
||||
(or (find file-exists? names)
|
||||
(first names))))
|
||||
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(define mapping
|
||||
|
|
@ -541,23 +584,23 @@ (define mapping
|
|||
|
||||
(lambda (name)
|
||||
(or (assoc-ref mapping name)
|
||||
(module-name->file-name/guess directory name))))
|
||||
(guess-file-name name))))
|
||||
(lambda args
|
||||
(if (= ENOENT (system-error-errno args))
|
||||
(cut module-name->file-name/guess directory <>)
|
||||
(cut guess-file-name <>)
|
||||
(apply throw args)))))
|
||||
|
||||
(define (write-module-name-database directory)
|
||||
"Write a database that maps \"module names\" as they appear in the relevant
|
||||
ELF section of '.ko' files, to actual file names. This format is
|
||||
ELF section of '.ko[.gz|.xz]' files, to actual file names. This format is
|
||||
Guix-specific. It aims to deal with inconsistent naming, in particular
|
||||
hyphens vs. underscores."
|
||||
(define mapping
|
||||
(map (lambda (file)
|
||||
(match (module-formal-name file)
|
||||
(#f (cons (basename file ".ko") file))
|
||||
(#f (cons (strip-extension (basename file)) file))
|
||||
(name (cons name file))))
|
||||
(find-files directory "\\.ko$")))
|
||||
(find-files directory module-regex)))
|
||||
|
||||
(call-with-output-file (string-append directory "/modules.name")
|
||||
(lambda (port)
|
||||
|
|
@ -569,12 +612,12 @@ (define mapping
|
|||
(pretty-print mapping port))))
|
||||
|
||||
(define (write-module-alias-database directory)
|
||||
"Traverse the '.ko' files in DIRECTORY and create the corresponding
|
||||
"Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
|
||||
'modules.alias' file."
|
||||
(define aliases
|
||||
(map (lambda (file)
|
||||
(cons (file-name->module-name file) (module-aliases file)))
|
||||
(find-files directory "\\.ko$")))
|
||||
(find-files directory module-regex)))
|
||||
|
||||
(call-with-output-file (string-append directory "/modules.alias")
|
||||
(lambda (port)
|
||||
|
|
@ -616,7 +659,7 @@ (define %not-dash
|
|||
(char-set-complement (char-set #\-)))
|
||||
|
||||
(define (write-module-device-database directory)
|
||||
"Traverse the '.ko' files in DIRECTORY and create the corresponding
|
||||
"Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
|
||||
'modules.devname' file. This file contains information about modules that can
|
||||
be loaded on-demand, such as file system modules."
|
||||
(define aliases
|
||||
|
|
@ -624,7 +667,7 @@ (define aliases
|
|||
(match (aliases->device-tuple (module-aliases file))
|
||||
(#f #f)
|
||||
(tuple (cons (file-name->module-name file) tuple))))
|
||||
(find-files directory "\\.ko$")))
|
||||
(find-files directory module-regex)))
|
||||
|
||||
(call-with-output-file (string-append directory "/modules.devname")
|
||||
(lambda (port)
|
||||
|
|
|
|||
|
|
@ -342,7 +342,8 @@ (define installer-builder
|
|||
;; packages …), etc. modules.
|
||||
(with-extensions (list guile-gcrypt guile-newt
|
||||
guile-parted guile-bytestructures
|
||||
guile-json-3 guile-git guix)
|
||||
guile-json-3 guile-git guile-zlib
|
||||
guix)
|
||||
(with-imported-modules `(,@(source-module-closure
|
||||
`(,@modules
|
||||
(gnu services herd)
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ (define-module (gnu machine ssh)
|
|||
#:use-module (gnu bootloader)
|
||||
#:use-module (gnu machine)
|
||||
#:autoload (gnu packages gnupg) (guile-gcrypt)
|
||||
#:autoload (gnu packages guile) (guile-zlib)
|
||||
#:use-module (gnu system)
|
||||
#:use-module (gnu system file-systems)
|
||||
#:use-module (gnu system uuid)
|
||||
|
|
@ -248,22 +249,24 @@ (define remote-exp
|
|||
'((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))
|
||||
(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)))))
|
||||
(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)))))))
|
||||
(missing-modules dev
|
||||
'#$(operating-system-initrd-modules
|
||||
(machine-operating-system machine))))))))
|
||||
|
||||
(remote-let ((missing remote-exp))
|
||||
(unless (null? missing)
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@ (define-module (gnu services)
|
|||
#:use-module (guix modules)
|
||||
#:use-module (gnu packages base)
|
||||
#:use-module (gnu packages bash)
|
||||
#:use-module (gnu packages guile)
|
||||
#:use-module (gnu packages hurd)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
|
|
@ -585,28 +586,29 @@ (define actions
|
|||
(with-imported-modules (source-module-closure
|
||||
'((gnu build activation)
|
||||
(guix build utils)))
|
||||
#~(begin
|
||||
(use-modules (gnu build activation)
|
||||
(guix build utils))
|
||||
(with-extensions (list guile-zlib)
|
||||
#~(begin
|
||||
(use-modules (gnu build activation)
|
||||
(guix build utils))
|
||||
|
||||
;; Make sure the user accounting database exists. If it
|
||||
;; does not exist, 'setutxent' does not create it and
|
||||
;; thus there is no accounting at all.
|
||||
(close-port (open-file "/var/run/utmpx" "a0"))
|
||||
;; 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"))
|
||||
;; 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)
|
||||
;; 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)))))
|
||||
;; 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."
|
||||
|
|
|
|||
|
|
@ -50,6 +50,7 @@ (define-module (gnu services base)
|
|||
#:select (coreutils glibc glibc-utf8-locales))
|
||||
#:use-module (gnu packages package-management)
|
||||
#:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
|
||||
#:use-module ((gnu packages guile) #:select (guile-zlib))
|
||||
#:use-module (gnu packages linux)
|
||||
#:use-module (gnu packages terminals)
|
||||
#:use-module ((gnu build file-systems)
|
||||
|
|
@ -836,36 +837,38 @@ (define (default-serial-port)
|
|||
to use as the tty. This is primarily useful for headless systems."
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build linux-boot))) ;for 'find-long-options'
|
||||
#~(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 @@ (define agetty-shepherd-service
|
|||
(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 @@ (define udev-shepherd-service
|
|||
(start
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build linux-boot)))
|
||||
#~(lambda ()
|
||||
(define udevd
|
||||
;; 'udevd' from eudev.
|
||||
#$(file-append udev "/sbin/udevd"))
|
||||
(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))))))
|
||||
(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")
|
||||
;; 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* ((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)
|
||||
(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")
|
||||
;; 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))))
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@ (define gcrypt-sqlite3&co
|
|||
(match (package-transitive-propagated-inputs package)
|
||||
(((labels packages) ...)
|
||||
packages))))
|
||||
(list guile-gcrypt guile-sqlite3)))
|
||||
(list guile-gcrypt guile-sqlite3 guile-zlib)))
|
||||
|
||||
(define-syntax-rule (with-imported-modules* gexp* ...)
|
||||
(with-extensions gcrypt-sqlite3&co
|
||||
|
|
|
|||
|
|
@ -77,6 +77,9 @@ (define init
|
|||
(program-file "init" exp #:guile guile))
|
||||
|
||||
(define builder
|
||||
;; Do not use "guile-zlib" extension here, otherwise it would drag the
|
||||
;; non-static "zlib" package to the initrd closure. It is not needed
|
||||
;; anyway because the modules are stored uncompressed within the initrd.
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build linux-initrd)))
|
||||
#~(begin
|
||||
|
|
@ -111,34 +114,49 @@ (define builder
|
|||
(define (flat-linux-module-directory linux modules)
|
||||
"Return a flat directory containing the Linux kernel modules listed in
|
||||
MODULES and taken from LINUX."
|
||||
(define imported-modules
|
||||
(source-module-closure '((gnu build linux-modules)
|
||||
(guix build utils))))
|
||||
|
||||
(define build-exp
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build linux-modules)))
|
||||
#~(begin
|
||||
(use-modules (gnu build linux-modules)
|
||||
(srfi srfi-1)
|
||||
(srfi srfi-26))
|
||||
(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 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 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))
|
||||
(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))))
|
||||
|
||||
;; Hyphen or underscore? This database tells us.
|
||||
(write-module-name-database #$output))))
|
||||
(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))
|
||||
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ (define-module (gnu system shadow)
|
|||
#:use-module ((gnu packages admin)
|
||||
#:select (shadow))
|
||||
#:use-module (gnu packages bash)
|
||||
#:use-module (gnu packages guile)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
|
|
@ -324,11 +325,12 @@ (define accounts
|
|||
(start (with-imported-modules (source-module-closure
|
||||
'((gnu build activation)
|
||||
(gnu system accounts)))
|
||||
#~(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)
|
||||
|
|
|
|||
|
|
@ -1205,43 +1205,48 @@ (define (linux-module-database manifest)
|
|||
This is meant to be used as a profile hook."
|
||||
(define kmod ; lazy reference
|
||||
(module-ref (resolve-interface '(gnu packages linux)) 'kmod))
|
||||
|
||||
(define guile-zlib
|
||||
(module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
|
||||
|
||||
(define build
|
||||
(with-imported-modules (source-module-closure
|
||||
'((guix build utils)
|
||||
(gnu build linux-modules)))
|
||||
#~(begin
|
||||
(use-modules (ice-9 ftw)
|
||||
(ice-9 match)
|
||||
(srfi srfi-1) ; append-map
|
||||
(gnu build linux-modules))
|
||||
(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")))))))
|
||||
(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
|
||||
|
|
|
|||
Loading…
Reference in a new issue