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.

1 files changed, 218 insertions, 210 deletions

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