summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gnu/build/linux-modules.scm115
-rw-r--r--gnu/installer.scm3
-rw-r--r--gnu/machine/ssh.scm35
-rw-r--r--gnu/services.scm46
-rw-r--r--gnu/services/base.scm428
-rw-r--r--gnu/system/image.scm2
-rw-r--r--gnu/system/linux-initrd.scm72
-rw-r--r--gnu/system/shadow.scm12
-rw-r--r--guix/profiles.scm71
9 files changed, 433 insertions, 351 deletions
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index aa1c7cfeae2..3a473220655 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -24,6 +24,7 @@
24 #:use-module (guix build syscalls) 24 #:use-module (guix build syscalls)
25 #:use-module ((guix build utils) #:select (find-files invoke)) 25 #:use-module ((guix build utils) #:select (find-files invoke))
26 #:use-module (guix build union) 26 #:use-module (guix build union)
27 #:autoload (zlib) (call-with-gzip-input-port)
27 #:use-module (rnrs io ports) 28 #:use-module (rnrs io ports)
28 #:use-module (rnrs bytevectors) 29 #:use-module (rnrs bytevectors)
29 #:use-module (srfi srfi-1) 30 #:use-module (srfi srfi-1)
@@ -94,10 +95,28 @@ string list."
94 (cons (string->symbol (string-take str =)) 95 (cons (string->symbol (string-take str =))
95 (string-drop str (+ 1 =))))) 96 (string-drop str (+ 1 =)))))
96 97
98;; Matches kernel modules, without compression, with GZIP compression or with
99;; XZ compression.
100(define module-regex "\\.ko(\\.gz|\\.xz)?$")
101
97(define (modinfo-section-contents file) 102(define (modinfo-section-contents file)
98 "Return the contents of the '.modinfo' section of FILE as a list of 103 "Return the contents of the '.modinfo' section of FILE as a list of
99key/value pairs.." 104key/value pairs.."
100 (let* ((bv (call-with-input-file file get-bytevector-all)) 105 (define (get-bytevector file)
106 (cond
107 ((string-suffix? ".ko.gz" file)
108 (let ((port (open-file file "r0")))
109 (dynamic-wind
110 (lambda ()
111 #t)
112 (lambda ()
113 (call-with-gzip-input-port port get-bytevector-all))
114 (lambda ()
115 (close-port port)))))
116 (else
117 (call-with-input-file file get-bytevector-all))))
118
119 (let* ((bv (get-bytevector file))
101 (elf (parse-elf bv)) 120 (elf (parse-elf bv))
102 (section (elf-section-by-name elf ".modinfo")) 121 (section (elf-section-by-name elf ".modinfo"))
103 (modinfo (section-contents elf section))) 122 (modinfo (section-contents elf section)))
@@ -110,7 +129,7 @@ key/value pairs.."
110(define (module-formal-name file) 129(define (module-formal-name file)
111 "Return the module name of FILE as it appears in its info section. Usually 130 "Return the module name of FILE as it appears in its info section. Usually
112the module name is the same as the base name of FILE, modulo hyphens and minus 131the module name is the same as the base name of FILE, modulo hyphens and minus
113the \".ko\" extension." 132the \".ko[.gz|.xz]\" extension."
114 (match (assq 'name (modinfo-section-contents file)) 133 (match (assq 'name (modinfo-section-contents file))
115 (('name . name) name) 134 (('name . name) name)
116 (#f #f))) 135 (#f #f)))
@@ -171,14 +190,25 @@ modules that can be postloaded, of the soft dependencies of module FILE."
171 (_ #f)) 190 (_ #f))
172 (modinfo-section-contents file)))) 191 (modinfo-section-contents file))))
173 192
174(define dot-ko 193(define (strip-extension filename)
175 (cut string-append <> ".ko")) 194 (let ((extension (string-index filename #\.)))
176 195 (if extension
177(define (ensure-dot-ko name) 196 (string-take filename extension)
178 "Return NAME with a '.ko' prefix appended, unless it already has it." 197 filename)))
179 (if (string-suffix? ".ko" name) 198
199(define (dot-ko name compression)
200 (let ((suffix (match compression
201 ('xz ".ko.xz")
202 ('gzip ".ko.gz")
203 (else ".ko"))))
204 (string-append name suffix)))
205
206(define (ensure-dot-ko name compression)
207 "Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has
208it."
209 (if (string-contains name ".ko")
180 name 210 name
181 (dot-ko name))) 211 (dot-ko name compression)))
182 212
183(define (normalize-module-name module) 213(define (normalize-module-name module)
184 "Return the \"canonical\" name for MODULE, replacing hyphens with 214 "Return the \"canonical\" name for MODULE, replacing hyphens with
@@ -191,9 +221,9 @@ underscores."
191 module)) 221 module))
192 222
193(define (file-name->module-name file) 223(define (file-name->module-name file)
194 "Return the module name corresponding to FILE, stripping the trailing '.ko' 224 "Return the module name corresponding to FILE, stripping the trailing
195and normalizing it." 225'.ko[.gz|.xz]' and normalizing it."
196 (normalize-module-name (basename file ".ko"))) 226 (normalize-module-name (strip-extension (basename file))))
197 227
198(define (find-module-file directory module) 228(define (find-module-file directory module)
199 "Lookup module NAME under DIRECTORY, and return its absolute file name. 229 "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:
208 ;; List of possible file names. XXX: It would of course be cleaner to 238 ;; List of possible file names. XXX: It would of course be cleaner to
209 ;; have a database that maps module names to file names and vice versa, 239 ;; have a database that maps module names to file names and vice versa,
210 ;; but everyone seems to be doing hacks like this one. Oh well! 240 ;; but everyone seems to be doing hacks like this one. Oh well!
211 (map ensure-dot-ko 241 (delete-duplicates
212 (delete-duplicates 242 (list module
213 (list module 243 (normalize-module-name module)
214 (normalize-module-name module) 244 (string-map (lambda (chr) ;converse of 'normalize-module-name'
215 (string-map (lambda (chr) ;converse of 'normalize-module-name' 245 (case chr
216 (case chr 246 ((#\_) #\-)
217 ((#\_) #\-) 247 (else chr)))
218 (else chr))) 248 module))))
219 module)))))
220 249
221 (match (find-files directory 250 (match (find-files directory
222 (lambda (file stat) 251 (lambda (file stat)
223 (member (basename file) names))) 252 (member (strip-extension
253 (basename file)) names)))
224 ((file) 254 ((file)
225 file) 255 file)
226 (() 256 (()
@@ -290,8 +320,8 @@ not a file name."
290 (recursive? #t) 320 (recursive? #t)
291 (lookup-module dot-ko) 321 (lookup-module dot-ko)
292 (black-list (module-black-list))) 322 (black-list (module-black-list)))
293 "Load Linux module from FILE, the name of a '.ko' file; return true on 323 "Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true
294success, false otherwise. When RECURSIVE? is true, load its dependencies 324on success, false otherwise. When RECURSIVE? is true, load its dependencies
295first (à la 'modprobe'.) The actual files containing modules depended on are 325first (à la 'modprobe'.) The actual files containing modules depended on are
296obtained by calling LOOKUP-MODULE with the module name. Modules whose name 326obtained by calling LOOKUP-MODULE with the module name. Modules whose name
297appears in BLACK-LIST are not loaded." 327appears in BLACK-LIST are not loaded."
@@ -523,16 +553,29 @@ are required to access DEVICE."
523;;; Module databases. 553;;; Module databases.
524;;; 554;;;
525 555
526(define (module-name->file-name/guess directory name) 556(define* (module-name->file-name/guess directory name
557 #:key compression)
527 "Guess the file name corresponding to NAME, a module name. That doesn't 558 "Guess the file name corresponding to NAME, a module name. That doesn't
528always work because sometimes underscores in NAME map to hyphens (e.g., 559always work because sometimes underscores in NAME map to hyphens (e.g.,
529\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\")." 560\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\"). If the module is
530 (string-append directory "/" (ensure-dot-ko name))) 561compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the
562compression type."
563 (string-append directory "/" (ensure-dot-ko name compression)))
531 564
532(define (module-name-lookup directory) 565(define (module-name-lookup directory)
533 "Return a one argument procedure that takes a module name (e.g., 566 "Return a one argument procedure that takes a module name (e.g.,
534\"input_leds\") and returns its absolute file name (e.g., 567\"input_leds\") and returns its absolute file name (e.g.,
535\"/.../input-leds.ko\")." 568\"/.../input-leds.ko\")."
569 (define (guess-file-name name)
570 (let ((names (list
571 (module-name->file-name/guess directory name)
572 (module-name->file-name/guess directory name
573 #:compression 'xz)
574 (module-name->file-name/guess directory name
575 #:compression 'gzip))))
576 (or (find file-exists? names)
577 (first names))))
578
536 (catch 'system-error 579 (catch 'system-error
537 (lambda () 580 (lambda ()
538 (define mapping 581 (define mapping
@@ -541,23 +584,23 @@ always work because sometimes underscores in NAME map to hyphens (e.g.,
541 584
542 (lambda (name) 585 (lambda (name)
543 (or (assoc-ref mapping name) 586 (or (assoc-ref mapping name)
544 (module-name->file-name/guess directory name)))) 587 (guess-file-name name))))
545 (lambda args 588 (lambda args
546 (if (= ENOENT (system-error-errno args)) 589 (if (= ENOENT (system-error-errno args))
547 (cut module-name->file-name/guess directory <>) 590 (cut guess-file-name <>)
548 (apply throw args))))) 591 (apply throw args)))))
549 592
550(define (write-module-name-database directory) 593(define (write-module-name-database directory)
551 "Write a database that maps \"module names\" as they appear in the relevant 594 "Write a database that maps \"module names\" as they appear in the relevant
552ELF section of '.ko' files, to actual file names. This format is 595ELF section of '.ko[.gz|.xz]' files, to actual file names. This format is
553Guix-specific. It aims to deal with inconsistent naming, in particular 596Guix-specific. It aims to deal with inconsistent naming, in particular
554hyphens vs. underscores." 597hyphens vs. underscores."
555 (define mapping 598 (define mapping
556 (map (lambda (file) 599 (map (lambda (file)
557 (match (module-formal-name file) 600 (match (module-formal-name file)
558 (#f (cons (basename file ".ko") file)) 601 (#f (cons (strip-extension (basename file)) file))
559 (name (cons name file)))) 602 (name (cons name file))))
560 (find-files directory "\\.ko$"))) 603 (find-files directory module-regex)))
561 604
562 (call-with-output-file (string-append directory "/modules.name") 605 (call-with-output-file (string-append directory "/modules.name")
563 (lambda (port) 606 (lambda (port)
@@ -569,12 +612,12 @@ hyphens vs. underscores."
569 (pretty-print mapping port)))) 612 (pretty-print mapping port))))
570 613
571(define (write-module-alias-database directory) 614(define (write-module-alias-database directory)
572 "Traverse the '.ko' files in DIRECTORY and create the corresponding 615 "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
573'modules.alias' file." 616'modules.alias' file."
574 (define aliases 617 (define aliases
575 (map (lambda (file) 618 (map (lambda (file)
576 (cons (file-name->module-name file) (module-aliases file))) 619 (cons (file-name->module-name file) (module-aliases file)))
577 (find-files directory "\\.ko$"))) 620 (find-files directory module-regex)))
578 621
579 (call-with-output-file (string-append directory "/modules.alias") 622 (call-with-output-file (string-append directory "/modules.alias")
580 (lambda (port) 623 (lambda (port)
@@ -616,7 +659,7 @@ are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f."
616 (char-set-complement (char-set #\-))) 659 (char-set-complement (char-set #\-)))
617 660
618(define (write-module-device-database directory) 661(define (write-module-device-database directory)
619 "Traverse the '.ko' files in DIRECTORY and create the corresponding 662 "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
620'modules.devname' file. This file contains information about modules that can 663'modules.devname' file. This file contains information about modules that can
621be loaded on-demand, such as file system modules." 664be loaded on-demand, such as file system modules."
622 (define aliases 665 (define aliases
@@ -624,7 +667,7 @@ be loaded on-demand, such as file system modules."
624 (match (aliases->device-tuple (module-aliases file)) 667 (match (aliases->device-tuple (module-aliases file))
625 (#f #f) 668 (#f #f)
626 (tuple (cons (file-name->module-name file) tuple)))) 669 (tuple (cons (file-name->module-name file) tuple))))
627 (find-files directory "\\.ko$"))) 670 (find-files directory module-regex)))
628 671
629 (call-with-output-file (string-append directory "/modules.devname") 672 (call-with-output-file (string-append directory "/modules.devname")
630 (lambda (port) 673 (lambda (port)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 5c3192d7a69..576ac90a4b6 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -342,7 +342,8 @@ selected keymap."
342 ;; packages …), etc. modules. 342 ;; packages …), etc. modules.
343 (with-extensions (list guile-gcrypt guile-newt 343 (with-extensions (list guile-gcrypt guile-newt
344 guile-parted guile-bytestructures 344 guile-parted guile-bytestructures
345 guile-json-3 guile-git guix) 345 guile-json-3 guile-git guile-zlib
346 guix)
346 (with-imported-modules `(,@(source-module-closure 347 (with-imported-modules `(,@(source-module-closure
347 `(,@modules 348 `(,@modules
348 (gnu services herd) 349 (gnu services herd)
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 4e31baa4b96..ee5032e2810 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -21,6 +21,7 @@
21 #:use-module (gnu bootloader) 21 #:use-module (gnu bootloader)
22 #:use-module (gnu machine) 22 #:use-module (gnu machine)
23 #:autoload (gnu packages gnupg) (guile-gcrypt) 23 #:autoload (gnu packages gnupg) (guile-gcrypt)
24 #:autoload (gnu packages guile) (guile-zlib)
24 #:use-module (gnu system) 25 #:use-module (gnu system)
25 #:use-module (gnu system file-systems) 26 #:use-module (gnu system file-systems)
26 #:use-module (gnu system uuid) 27 #:use-module (gnu system uuid)
@@ -248,22 +249,24 @@ not available in the initrd."
248 '((gnu build file-systems) 249 '((gnu build file-systems)
249 (gnu build linux-modules) 250 (gnu build linux-modules)
250 (gnu system uuid))) 251 (gnu system uuid)))
251 #~(begin 252 (with-extensions (list guile-zlib)
252 (use-modules (gnu build file-systems) 253 #~(begin
253 (gnu build linux-modules) 254 (use-modules (gnu build file-systems)
254 (gnu system uuid)) 255 (gnu build linux-modules)
255 256 (gnu system uuid))
256 (define dev 257
257 #$(cond ((string? device) device) 258 (define dev
258 ((uuid? device) #~(find-partition-by-uuid 259 #$(cond ((string? device) device)
259 (string->uuid 260 ((uuid? device) #~(find-partition-by-uuid
260 #$(uuid->string device)))) 261 (string->uuid
261 ((file-system-label? device) 262 #$(uuid->string device))))
262 #~(find-partition-by-label 263 ((file-system-label? device)
263 #$(file-system-label->string device))))) 264 #~(find-partition-by-label
264 265 #$(file-system-label->string device)))))
265 (missing-modules dev '#$(operating-system-initrd-modules 266
266 (machine-operating-system machine))))))) 267 (missing-modules dev
268 '#$(operating-system-initrd-modules
269 (machine-operating-system machine))))))))
267 270
268 (remote-let ((missing remote-exp)) 271 (remote-let ((missing remote-exp))
269 (unless (null? missing) 272 (unless (null? missing)
diff --git a/gnu/services.scm b/gnu/services.scm
index 11ba21e8245..3e59c6401f6 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -35,6 +35,7 @@
35 #:use-module (guix modules) 35 #:use-module (guix modules)
36 #:use-module (gnu packages base) 36 #:use-module (gnu packages base)
37 #:use-module (gnu packages bash) 37 #:use-module (gnu packages bash)
38 #:use-module (gnu packages guile)
38 #:use-module (gnu packages hurd) 39 #:use-module (gnu packages hurd)
39 #:use-module (srfi srfi-1) 40 #:use-module (srfi srfi-1)
40 #:use-module (srfi srfi-9) 41 #:use-module (srfi srfi-9)
@@ -585,28 +586,29 @@ ACTIVATION-SCRIPT-TYPE."
585 (with-imported-modules (source-module-closure 586 (with-imported-modules (source-module-closure
586 '((gnu build activation) 587 '((gnu build activation)
587 (guix build utils))) 588 (guix build utils)))
588 #~(begin 589 (with-extensions (list guile-zlib)
589 (use-modules (gnu build activation) 590 #~(begin
590 (guix build utils)) 591 (use-modules (gnu build activation)
591 592 (guix build utils))
592 ;; Make sure the user accounting database exists. If it 593
593 ;; does not exist, 'setutxent' does not create it and 594 ;; Make sure the user accounting database exists. If
594 ;; thus there is no accounting at all. 595 ;; it does not exist, 'setutxent' does not create it
595 (close-port (open-file "/var/run/utmpx" "a0")) 596 ;; and thus there is no accounting at all.
596 597 (close-port (open-file "/var/run/utmpx" "a0"))
597 ;; Same for 'wtmp', which is populated by mingetty et 598
598 ;; al. 599 ;; Same for 'wtmp', which is populated by mingetty et
599 (mkdir-p "/var/log") 600 ;; al.
600 (close-port (open-file "/var/log/wtmp" "a0")) 601 (mkdir-p "/var/log")
601 602 (close-port (open-file "/var/log/wtmp" "a0"))
602 ;; Set up /run/current-system. Among other things this 603
603 ;; sets up locales, which the activation snippets 604 ;; Set up /run/current-system. Among other things
604 ;; executed below may expect. 605 ;; this sets up locales, which the activation snippets
605 (activate-current-system) 606 ;; executed below may expect.
606 607 (activate-current-system)
607 ;; Run the services' activation snippets. 608
608 ;; TODO: Use 'load-compiled'. 609 ;; Run the services' activation snippets.
609 (for-each primitive-load '#$actions))))) 610 ;; TODO: Use 'load-compiled'.
611 (for-each primitive-load '#$actions))))))
610 612
611(define (gexps->activation-gexp gexps) 613(define (gexps->activation-gexp gexps)
612 "Return a gexp that runs the activation script containing GEXPS." 614 "Return a gexp that runs the activation script containing GEXPS."
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 491f35702a0..966e7fe024a 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -50,6 +50,7 @@
50 #:select (coreutils glibc glibc-utf8-locales)) 50 #:select (coreutils glibc glibc-utf8-locales))
51 #:use-module (gnu packages package-management) 51 #:use-module (gnu packages package-management)
52 #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) 52 #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
53 #:use-module ((gnu packages guile) #:select (guile-zlib))
53 #:use-module (gnu packages linux) 54 #:use-module (gnu packages linux)
54 #:use-module (gnu packages terminals) 55 #:use-module (gnu packages terminals)
55 #:use-module ((gnu build file-systems) 56 #:use-module ((gnu build file-systems)
@@ -836,36 +837,38 @@ the message of the day, among other things."
836to use as the tty. This is primarily useful for headless systems." 837to use as the tty. This is primarily useful for headless systems."
837 (with-imported-modules (source-module-closure 838 (with-imported-modules (source-module-closure
838 '((gnu build linux-boot))) ;for 'find-long-options' 839 '((gnu build linux-boot))) ;for 'find-long-options'
839 #~(begin 840 (with-extensions (list guile-zlib)
840 ;; console=device,options 841 #~(begin
841 ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). 842 ;; console=device,options
842 ;; options: BBBBPNF. P n|o|e, N number of bits, 843 ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
843 ;; F flow control (r RTS) 844 ;; options: BBBBPNF. P n|o|e, N number of bits,
844 (let* ((not-comma (char-set-complement (char-set #\,))) 845 ;; F flow control (r RTS)
845 (command (linux-command-line)) 846 (let* ((not-comma (char-set-complement (char-set #\,)))
846 (agetty-specs (find-long-options "agetty.tty" command)) 847 (command (linux-command-line))
847 (console-specs (filter (lambda (spec) 848 (agetty-specs (find-long-options "agetty.tty" command))
848 (and (string-prefix? "tty" spec) 849 (console-specs
849 (not (or 850 (filter (lambda (spec)
850 (string-prefix? "tty0" spec) 851 (and (string-prefix? "tty" spec)
851 (string-prefix? "tty1" spec) 852 (not (or
852 (string-prefix? "tty2" spec) 853 (string-prefix? "tty0" spec)
853 (string-prefix? "tty3" spec) 854 (string-prefix? "tty1" spec)
854 (string-prefix? "tty4" spec) 855 (string-prefix? "tty2" spec)
855 (string-prefix? "tty5" spec) 856 (string-prefix? "tty3" spec)
856 (string-prefix? "tty6" spec) 857 (string-prefix? "tty4" spec)
857 (string-prefix? "tty7" spec) 858 (string-prefix? "tty5" spec)
858 (string-prefix? "tty8" spec) 859 (string-prefix? "tty6" spec)
859 (string-prefix? "tty9" spec))))) 860 (string-prefix? "tty7" spec)
860 (find-long-options "console" command))) 861 (string-prefix? "tty8" spec)
861 (specs (append agetty-specs console-specs))) 862 (string-prefix? "tty9" spec)))))
862 (match specs 863 (find-long-options "console" command)))
863 (() #f) 864 (specs (append agetty-specs console-specs)))
864 ((spec _ ...) 865 (match specs
865 ;; Extract device name from first spec. 866 (() #f)
866 (match (string-tokenize spec not-comma) 867 ((spec _ ...)
867 ((device-name _ ...) 868 ;; Extract device name from first spec.
868 device-name)))))))) 869 (match (string-tokenize spec not-comma)
870 ((device-name _ ...)
871 device-name)))))))))
869 872
870(define agetty-shepherd-service 873(define agetty-shepherd-service
871 (match-lambda 874 (match-lambda
@@ -890,122 +893,124 @@ to use as the tty. This is primarily useful for headless systems."
890 (start 893 (start
891 (with-imported-modules (source-module-closure 894 (with-imported-modules (source-module-closure
892 '((gnu build linux-boot))) 895 '((gnu build linux-boot)))
893 #~(lambda args 896 (with-extensions (list guile-zlib)
894 (let ((defaulted-tty #$(or tty (default-serial-port)))) 897 #~(lambda args
895 (apply 898 (let ((defaulted-tty #$(or tty (default-serial-port))))
896 (if defaulted-tty 899 (apply
897 (make-forkexec-constructor 900 (if defaulted-tty
898 (list #$(file-append util-linux "/sbin/agetty") 901 (make-forkexec-constructor
899 #$@extra-options 902 (list #$(file-append util-linux "/sbin/agetty")
900 #$@(if eight-bits? 903 #$@extra-options
901 #~("--8bits") 904 #$@(if eight-bits?
902 #~()) 905 #~("--8bits")
903 #$@(if no-reset? 906 #~())
904 #~("--noreset") 907 #$@(if no-reset?
905 #~()) 908 #~("--noreset")
906 #$@(if remote? 909 #~())
907 #~("--remote") 910 #$@(if remote?
908 #~()) 911 #~("--remote")
909 #$@(if flow-control? 912 #~())
910 #~("--flow-control") 913 #$@(if flow-control?
911 #~()) 914 #~("--flow-control")
912 #$@(if host 915 #~())
913 #~("--host" #$host) 916 #$@(if host
914 #~()) 917 #~("--host" #$host)
915 #$@(if no-issue? 918 #~())
916 #~("--noissue") 919 #$@(if no-issue?
917 #~()) 920 #~("--noissue")
918 #$@(if init-string 921 #~())
919 #~("--init-string" #$init-string) 922 #$@(if init-string
920 #~()) 923 #~("--init-string" #$init-string)
921 #$@(if no-clear? 924 #~())
922 #~("--noclear") 925 #$@(if no-clear?
923 #~()) 926 #~("--noclear")
924;;; FIXME This doesn't work as expected. According to agetty(8), if this option 927 #~())
925;;; is not passed, then the default is 'auto'. However, in my tests, when that 928;;; FIXME This doesn't work as expected. According to agetty(8), if this
926;;; option is selected, agetty never presents the login prompt, and the 929;;; option is not passed, then the default is 'auto'. However, in my tests,
927;;; term-ttyS0 service respawns every few seconds. 930;;; when that option is selected, agetty never presents the login prompt, and
928 #$@(if local-line 931;;; the term-ttyS0 service respawns every few seconds.
929 #~(#$(match local-line 932 #$@(if local-line
930 ('auto "--local-line=auto") 933 #~(#$(match local-line
931 ('always "--local-line=always") 934 ('auto "--local-line=auto")
932 ('never "-local-line=never"))) 935 ('always "--local-line=always")
933 #~()) 936 ('never "-local-line=never")))
934 #$@(if tty 937 #~())
935 #~() 938 #$@(if tty
936 #~("--keep-baud")) 939 #~()
937 #$@(if extract-baud? 940 #~("--keep-baud"))
938 #~("--extract-baud") 941 #$@(if extract-baud?
939 #~()) 942 #~("--extract-baud")
940 #$@(if skip-login? 943 #~())
941 #~("--skip-login") 944 #$@(if skip-login?
942 #~()) 945 #~("--skip-login")
943 #$@(if no-newline? 946 #~())
944 #~("--nonewline") 947 #$@(if no-newline?
945 #~()) 948 #~("--nonewline")
946 #$@(if login-options 949 #~())
947 #~("--login-options" #$login-options) 950 #$@(if login-options
948 #~()) 951 #~("--login-options" #$login-options)
949 #$@(if chroot 952 #~())
950 #~("--chroot" #$chroot) 953 #$@(if chroot
951 #~()) 954 #~("--chroot" #$chroot)
952 #$@(if hangup? 955 #~())
953 #~("--hangup") 956 #$@(if hangup?
954 #~()) 957 #~("--hangup")
955 #$@(if keep-baud? 958 #~())
956 #~("--keep-baud") 959 #$@(if keep-baud?
957 #~()) 960 #~("--keep-baud")
958 #$@(if timeout 961 #~())
959 #~("--timeout" #$(number->string timeout)) 962 #$@(if timeout
960 #~()) 963 #~("--timeout"
961 #$@(if detect-case? 964 #$(number->string timeout))
962 #~("--detect-case") 965 #~())
963 #~()) 966 #$@(if detect-case?
964 #$@(if wait-cr? 967 #~("--detect-case")
965 #~("--wait-cr") 968 #~())
966 #~()) 969 #$@(if wait-cr?
967 #$@(if no-hints? 970 #~("--wait-cr")
968 #~("--nohints?") 971 #~())
969 #~()) 972 #$@(if no-hints?
970 #$@(if no-hostname? 973 #~("--nohints?")
971 #~("--nohostname") 974 #~())
972 #~()) 975 #$@(if no-hostname?
973 #$@(if long-hostname? 976 #~("--nohostname")
974 #~("--long-hostname") 977 #~())
975 #~()) 978 #$@(if long-hostname?
976 #$@(if erase-characters 979 #~("--long-hostname")
977 #~("--erase-chars" #$erase-characters) 980 #~())
978 #~()) 981 #$@(if erase-characters
979 #$@(if kill-characters 982 #~("--erase-chars" #$erase-characters)
980 #~("--kill-chars" #$kill-characters) 983 #~())
981 #~()) 984 #$@(if kill-characters
982 #$@(if chdir 985 #~("--kill-chars" #$kill-characters)
983 #~("--chdir" #$chdir) 986 #~())
984 #~()) 987 #$@(if chdir
985 #$@(if delay 988 #~("--chdir" #$chdir)
986 #~("--delay" #$(number->string delay)) 989 #~())
987 #~()) 990 #$@(if delay
988 #$@(if nice 991 #~("--delay" #$(number->string delay))
989 #~("--nice" #$(number->string nice)) 992 #~())
990 #~()) 993 #$@(if nice
991 #$@(if auto-login 994 #~("--nice" #$(number->string nice))
992 (list "--autologin" auto-login) 995 #~())
993 '()) 996 #$@(if auto-login
994 #$@(if login-program 997 (list "--autologin" auto-login)
995 #~("--login-program" #$login-program) 998 '())
996 #~()) 999 #$@(if login-program
997 #$@(if login-pause? 1000 #~("--login-program" #$login-program)
998 #~("--login-pause") 1001 #~())
999 #~()) 1002 #$@(if login-pause?
1000 defaulted-tty 1003 #~("--login-pause")
1001 #$@(if baud-rate 1004 #~())
1002 #~(#$baud-rate) 1005 defaulted-tty
1003 #~()) 1006 #$@(if baud-rate
1004 #$@(if term 1007 #~(#$baud-rate)
1005 #~(#$term) 1008 #~())
1006 #~()))) 1009 #$@(if term
1007 (const #f)) ; never start. 1010 #~(#$term)
1008 args))))) 1011 #~())))
1012 (const #f)) ; never start.
1013 args))))))
1009 (stop #~(make-kill-destructor))))))) 1014 (stop #~(make-kill-destructor)))))))
1010 1015
1011(define agetty-service-type 1016(define agetty-service-type
@@ -1939,70 +1944,73 @@ item of @var{packages}."
1939 (start 1944 (start
1940 (with-imported-modules (source-module-closure 1945 (with-imported-modules (source-module-closure
1941 '((gnu build linux-boot))) 1946 '((gnu build linux-boot)))
1942 #~(lambda () 1947 (with-extensions (list guile-zlib)
1943 (define udevd 1948 #~(lambda ()
1944 ;; 'udevd' from eudev. 1949 (define udevd
1945 #$(file-append udev "/sbin/udevd")) 1950 ;; 'udevd' from eudev.
1946 1951 #$(file-append udev "/sbin/udevd"))
1947 (define (wait-for-udevd) 1952
1948 ;; Wait until someone's listening on udevd's control 1953 (define (wait-for-udevd)
1949 ;; socket. 1954 ;; Wait until someone's listening on udevd's control
1950 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) 1955 ;; socket.
1951 (let try () 1956 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1952 (catch 'system-error 1957 (let try ()
1953 (lambda () 1958 (catch 'system-error
1954 (connect sock PF_UNIX "/run/udev/control") 1959 (lambda ()
1955 (close-port sock)) 1960 (connect sock PF_UNIX "/run/udev/control")
1956 (lambda args 1961 (close-port sock))
1957 (format #t "waiting for udevd...~%") 1962 (lambda args
1958 (usleep 500000) 1963 (format #t "waiting for udevd...~%")
1959 (try)))))) 1964 (usleep 500000)
1960 1965 (try))))))
1961 ;; Allow udev to find the modules. 1966
1962 (setenv "LINUX_MODULE_DIRECTORY" 1967 ;; Allow udev to find the modules.
1963 "/run/booted-system/kernel/lib/modules") 1968 (setenv "LINUX_MODULE_DIRECTORY"
1964 1969 "/run/booted-system/kernel/lib/modules")
1965 (let* ((kernel-release 1970
1966 (utsname:release (uname))) 1971 (let* ((kernel-release
1967 (linux-module-directory 1972 (utsname:release (uname)))
1968 (getenv "LINUX_MODULE_DIRECTORY")) 1973 (linux-module-directory
1969 (directory 1974 (getenv "LINUX_MODULE_DIRECTORY"))
1970 (string-append linux-module-directory "/" 1975 (directory
1971 kernel-release)) 1976 (string-append linux-module-directory "/"
1972 (old-umask (umask #o022))) 1977 kernel-release))
1973 ;; If we're in a container, DIRECTORY might not exist, 1978 (old-umask (umask #o022)))
1974 ;; for instance because the host runs a different 1979 ;; If we're in a container, DIRECTORY might not exist,
1975 ;; kernel. In that case, skip it; we'll just miss a few 1980 ;; for instance because the host runs a different
1976 ;; nodes like /dev/fuse. 1981 ;; kernel. In that case, skip it; we'll just miss a few
1977 (when (file-exists? directory) 1982 ;; nodes like /dev/fuse.
1978 (make-static-device-nodes directory)) 1983 (when (file-exists? directory)
1979 (umask old-umask)) 1984 (make-static-device-nodes directory))
1980 1985 (umask old-umask))
1981 (let ((pid (fork+exec-command (list udevd) 1986
1982 #:environment-variables 1987 (let ((pid
1983 (cons* 1988 (fork+exec-command
1984 ;; The first one is for udev, the second one for 1989 (list udevd)
1985 ;; eudev. 1990 #:environment-variables
1986 (string-append "UDEV_CONFIG_FILE=" #$udev.conf) 1991 (cons*
1987 (string-append "EUDEV_RULES_DIRECTORY=" 1992 ;; The first one is for udev, the second one for
1988 #$(file-append 1993 ;; eudev.
1989 rules "/lib/udev/rules.d")) 1994 (string-append "UDEV_CONFIG_FILE=" #$udev.conf)
1990 (string-append "LINUX_MODULE_DIRECTORY=" 1995 (string-append "EUDEV_RULES_DIRECTORY="
1991 (getenv "LINUX_MODULE_DIRECTORY")) 1996 #$(file-append
1992 (default-environment-variables))))) 1997 rules "/lib/udev/rules.d"))
1993 ;; Wait until udevd is up and running. This appears to 1998 (string-append "LINUX_MODULE_DIRECTORY="
1994 ;; be needed so that the events triggered below are 1999 (getenv "LINUX_MODULE_DIRECTORY"))
1995 ;; actually handled. 2000 (default-environment-variables)))))
1996 (wait-for-udevd) 2001 ;; Wait until udevd is up and running. This appears to
1997 2002 ;; be needed so that the events triggered below are
1998 ;; Trigger device node creation. 2003 ;; actually handled.
1999 (system* #$(file-append udev "/bin/udevadm") 2004 (wait-for-udevd)
2000 "trigger" "--action=add") 2005
2001 2006 ;; Trigger device node creation.
2002 ;; Wait for things to settle down. 2007 (system* #$(file-append udev "/bin/udevadm")
2003 (system* #$(file-append udev "/bin/udevadm") 2008 "trigger" "--action=add")
2004 "settle") 2009
2005 pid)))) 2010 ;; Wait for things to settle down.
2011 (system* #$(file-append udev "/bin/udevadm")
2012 "settle")
2013 pid)))))
2006 (stop #~(make-kill-destructor)) 2014 (stop #~(make-kill-destructor))
2007 2015
2008 ;; When halting the system, 'udev' is actually killed by 2016 ;; When halting the system, 'udev' is actually killed by
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 36f56e237d5..19c99a3dfa1 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -141,7 +141,7 @@
141 (match (package-transitive-propagated-inputs package) 141 (match (package-transitive-propagated-inputs package)
142 (((labels packages) ...) 142 (((labels packages) ...)
143 packages)))) 143 packages))))
144 (list guile-gcrypt guile-sqlite3))) 144 (list guile-gcrypt guile-sqlite3 guile-zlib)))
145 145
146(define-syntax-rule (with-imported-modules* gexp* ...) 146(define-syntax-rule (with-imported-modules* gexp* ...)
147 (with-extensions gcrypt-sqlite3&co 147 (with-extensions gcrypt-sqlite3&co
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 0971ec29e21..b8a30c0abc6 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."
77 (program-file "init" exp #:guile guile)) 77 (program-file "init" exp #:guile guile))
78 78
79 (define builder 79 (define builder
80 ;; Do not use "guile-zlib" extension here, otherwise it would drag the
81 ;; non-static "zlib" package to the initrd closure. It is not needed
82 ;; anyway because the modules are stored uncompressed within the initrd.
80 (with-imported-modules (source-module-closure 83 (with-imported-modules (source-module-closure
81 '((gnu build linux-initrd))) 84 '((gnu build linux-initrd)))
82 #~(begin 85 #~(begin
@@ -111,34 +114,49 @@ the derivations referenced by EXP are automatically copied to the initrd."
111(define (flat-linux-module-directory linux modules) 114(define (flat-linux-module-directory linux modules)
112 "Return a flat directory containing the Linux kernel modules listed in 115 "Return a flat directory containing the Linux kernel modules listed in
113MODULES and taken from LINUX." 116MODULES and taken from LINUX."
114 (define build-exp 117 (define imported-modules
115 (with-imported-modules (source-module-closure 118 (source-module-closure '((gnu build linux-modules)
116 '((gnu build linux-modules))) 119 (guix build utils))))
117 #~(begin
118 (use-modules (gnu build linux-modules)
119 (srfi srfi-1)
120 (srfi srfi-26))
121
122 (define module-dir
123 (string-append #$linux "/lib/modules"))
124 120
125 (define modules 121 (define build-exp
126 (let* ((lookup (cut find-module-file module-dir <>)) 122 (with-imported-modules imported-modules
127 (modules (map lookup '#$modules))) 123 (with-extensions (list guile-zlib)
128 (append modules 124 #~(begin
129 (recursive-module-dependencies modules 125 (use-modules (gnu build linux-modules)
130 #:lookup-module lookup)))) 126 (guix build utils)
131 127 (srfi srfi-1)
132 (mkdir #$output) 128 (srfi srfi-26))
133 (for-each (lambda (module) 129
134 (format #t "copying '~a'...~%" module) 130 (define module-dir
135 (copy-file module 131 (string-append #$linux "/lib/modules"))
136 (string-append #$output "/" 132
137 (basename module)))) 133 (define modules
138 (delete-duplicates modules)) 134 (let* ((lookup (cut find-module-file module-dir <>))
139 135 (modules (map lookup '#$modules)))
140 ;; Hyphen or underscore? This database tells us. 136 (append modules
141 (write-module-name-database #$output)))) 137 (recursive-module-dependencies
138 modules
139 #:lookup-module lookup))))
140
141 (define (maybe-uncompress file)
142 ;; If FILE is a compressed module, uncompress it, as the initrd
143 ;; is already gzipped as a whole.
144 (cond
145 ((string-contains file ".ko.gz")
146 (invoke #+(file-append gzip "/bin/gunzip") file))))
147
148 (mkdir #$output)
149 (for-each (lambda (module)
150 (let ((out-module
151 (string-append #$output "/"
152 (basename module))))
153 (format #t "copying '~a'...~%" module)
154 (copy-file module out-module)
155 (maybe-uncompress out-module)))
156 (delete-duplicates modules))
157
158 ;; Hyphen or underscore? This database tells us.
159 (write-module-name-database #$output)))))
142 160
143 (computed-file "linux-modules" build-exp)) 161 (computed-file "linux-modules" build-exp))
144 162
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index a69339bc074..f642d250b0b 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -34,6 +34,7 @@
34 #:use-module ((gnu packages admin) 34 #:use-module ((gnu packages admin)
35 #:select (shadow)) 35 #:select (shadow))
36 #:use-module (gnu packages bash) 36 #:use-module (gnu packages bash)
37 #:use-module (gnu packages guile)
37 #:use-module (srfi srfi-1) 38 #:use-module (srfi srfi-1)
38 #:use-module (srfi srfi-26) 39 #:use-module (srfi srfi-26)
39 #:use-module (srfi srfi-34) 40 #:use-module (srfi srfi-34)
@@ -324,11 +325,12 @@ accounts among ACCOUNTS+GROUPS."
324 (start (with-imported-modules (source-module-closure 325 (start (with-imported-modules (source-module-closure
325 '((gnu build activation) 326 '((gnu build activation)
326 (gnu system accounts))) 327 (gnu system accounts)))
327 #~(lambda () 328 (with-extensions (list guile-zlib)
328 (activate-user-home 329 #~(lambda ()
329 (map sexp->user-account 330 (activate-user-home
330 (list #$@(map user-account->gexp accounts)))) 331 (map sexp->user-account
331 #t))) ;success 332 (list #$@(map user-account->gexp accounts))))
333 #t)))) ;success
332 (documentation "Create user home directories.")))) 334 (documentation "Create user home directories."))))
333 335
334(define (shells-file shells) 336(define (shells-file shells)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 6b2344270e2..856a05eed15 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1205,43 +1205,48 @@ and creates the dependency graph of all these kernel modules.
1205This is meant to be used as a profile hook." 1205This is meant to be used as a profile hook."
1206 (define kmod ; lazy reference 1206 (define kmod ; lazy reference
1207 (module-ref (resolve-interface '(gnu packages linux)) 'kmod)) 1207 (module-ref (resolve-interface '(gnu packages linux)) 'kmod))
1208
1209 (define guile-zlib
1210 (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
1211
1208 (define build 1212 (define build
1209 (with-imported-modules (source-module-closure 1213 (with-imported-modules (source-module-closure
1210 '((guix build utils) 1214 '((guix build utils)
1211 (gnu build linux-modules))) 1215 (gnu build linux-modules)))
1212 #~(begin 1216 (with-extensions (list guile-zlib)
1213 (use-modules (ice-9 ftw) 1217 #~(begin
1214 (ice-9 match) 1218 (use-modules (ice-9 ftw)
1215 (srfi srfi-1) ; append-map 1219 (ice-9 match)
1216 (gnu build linux-modules)) 1220 (srfi srfi-1) ; append-map
1217 1221 (gnu build linux-modules))
1218 (let* ((inputs '#$(manifest-inputs manifest)) 1222
1219 (module-directories 1223 (let* ((inputs '#$(manifest-inputs manifest))
1220 (map (lambda (directory) 1224 (module-directories
1221 (string-append directory "/lib/modules")) 1225 (map (lambda (directory)
1222 inputs)) 1226 (string-append directory "/lib/modules"))
1223 (directory-entries 1227 inputs))
1224 (lambda (directory) 1228 (directory-entries
1225 (or (scandir directory 1229 (lambda (directory)
1226 (lambda (basename) 1230 (or (scandir directory
1227 (not (string-prefix? "." basename)))) 1231 (lambda (basename)
1228 '()))) 1232 (not (string-prefix? "." basename))))
1229 ;; Note: Should usually result in one entry. 1233 '())))
1230 (versions (delete-duplicates 1234 ;; Note: Should usually result in one entry.
1231 (append-map directory-entries 1235 (versions (delete-duplicates
1232 module-directories)))) 1236 (append-map directory-entries
1233 (match versions 1237 module-directories))))
1234 ((version) 1238 (match versions
1235 (let ((old-path (getenv "PATH"))) 1239 ((version)
1236 (setenv "PATH" #+(file-append kmod "/bin")) 1240 (let ((old-path (getenv "PATH")))
1237 (make-linux-module-directory inputs version #$output) 1241 (setenv "PATH" #+(file-append kmod "/bin"))
1238 (setenv "PATH" old-path))) 1242 (make-linux-module-directory inputs version #$output)
1239 (() 1243 (setenv "PATH" old-path)))
1240 ;; Nothing here, maybe because this is a kernel with 1244 (()
1241 ;; CONFIG_MODULES=n. 1245 ;; Nothing here, maybe because this is a kernel with
1242 (mkdir #$output)) 1246 ;; CONFIG_MODULES=n.
1243 (_ (error "Specified Linux kernel and Linux kernel modules 1247 (mkdir #$output))
1244are not all of the same version"))))))) 1248 (_ (error "Specified Linux kernel and Linux kernel modules
1249are not all of the same version"))))))))
1245 (gexp->derivation "linux-module-database" build 1250 (gexp->derivation "linux-module-database" build
1246 #:local-build? #t 1251 #:local-build? #t
1247 #:substitutable? #f 1252 #:substitutable? #f
generated by cgit v1.2.3 (git 2.25.1) at 2026-09-03 07:21:37 +0000