me/guix
Archived
1
0
Fork 0
Code Activity

Remove "guile-zlib" extension when unused.

Browse source 
This is a follow-up of 755f365b02.

As (zlib) is autoloaded in (gnu build linux-modules), "guile-zlib" is needed
as an extension only when it is effectively used.

* gnu/installer.scm (installer-program): Remove "guile-zlib" from 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/shadow.scm (account-shepherd-service): Ditto.
This commit is contained in:
Mathieu Othacehe 2020-08-25 12:39:11 +02:00
parent 5fe12be0dd
commit dac7dd1b0b
No known key found for this signature in database
GPG key ID: 8354763531769CA6
6 changed files with 243 additions and 259 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
gnu/installer.scm
View file

@ -342,8 +342,7 @@ selected keymap."
;; packages …), etc. modules. ;; packages …), etc. modules.
(with-extensions (list guile-gcrypt guile-newt (with-extensions (list guile-gcrypt guile-newt
guile-parted guile-bytestructures guile-parted guile-bytestructures
guile-json-3 guile-git guile-zlib guile-json-3 guile-git guix)
guix)
(with-imported-modules `(,@(source-module-closure (with-imported-modules `(,@(source-module-closure
`(,@modules `(,@modules
(gnu services herd) (gnu services herd)

31
gnu/machine/ssh.scm
View file

@ -21,7 +21,6 @@
#:use-module (gnu bootloader) #:use-module (gnu bootloader)
#:use-module (gnu machine) #:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt) #:autoload (gnu packages gnupg) (guile-gcrypt)
#:autoload (gnu packages guile) (guile-zlib)
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
@ -249,24 +248,22 @@ not available in the initrd."
'((gnu build file-systems) '((gnu build file-systems)
(gnu build linux-modules) (gnu build linux-modules)
(gnu system uuid))) (gnu system uuid)))
(with-extensions (list guile-zlib) #~(begin
#~(begin (use-modules (gnu build file-systems)
(use-modules (gnu build file-systems) (gnu build linux-modules)
(gnu build linux-modules) (gnu system uuid))
(gnu system uuid))
(define dev (define dev
#$(cond ((string? device) device) #$(cond ((string? device) device)
((uuid? device) #~(find-partition-by-uuid ((uuid? device) #~(find-partition-by-uuid
(string->uuid (string->uuid
#$(uuid->string device)))) #$(uuid->string device))))
((file-system-label? device) ((file-system-label? device)
#~(find-partition-by-label #~(find-partition-by-label
#$(file-system-label->string device))))) #$(file-system-label->string device)))))
(missing-modules dev (missing-modules dev '#$(operating-system-initrd-modules
'#$(operating-system-initrd-modules (machine-operating-system machine)))))))
(machine-operating-system machine))))))))
(remote-let ((missing remote-exp)) (remote-let ((missing remote-exp))
(unless (null? missing) (unless (null? missing)

38
gnu/services.scm
View file

@ -35,7 +35,6 @@
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (gnu packages base) #:use-module (gnu packages base)
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages guile)
#:use-module (gnu packages hurd) #:use-module (gnu packages hurd)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
@ -586,29 +585,28 @@ ACTIVATION-SCRIPT-TYPE."
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((gnu build activation) '((gnu build activation)
(guix build utils))) (guix build utils)))
(with-extensions (list guile-zlib) #~(begin
#~(begin (use-modules (gnu build activation)
(use-modules (gnu build activation) (guix build utils))
(guix build utils))
;; Make sure the user accounting database exists. If ;; Make sure the user accounting database exists. If it
;; it does not exist, 'setutxent' does not create it ;; does not exist, 'setutxent' does not create it and
;; and thus there is no accounting at all. ;; thus there is no accounting at all.
(close-port (open-file "/var/run/utmpx" "a0")) (close-port (open-file "/var/run/utmpx" "a0"))
;; Same for 'wtmp', which is populated by mingetty et ;; Same for 'wtmp', which is populated by mingetty et
;; al. ;; al.
(mkdir-p "/var/log") (mkdir-p "/var/log")
(close-port (open-file "/var/log/wtmp" "a0")) (close-port (open-file "/var/log/wtmp" "a0"))
;; Set up /run/current-system. Among other things ;; Set up /run/current-system. Among other things this
;; this sets up locales, which the activation snippets ;; sets up locales, which the activation snippets
;; executed below may expect. ;; executed below may expect.
(activate-current-system) (activate-current-system)
;; Run the services' activation snippets. ;; Run the services' activation snippets.
;; TODO: Use 'load-compiled'. ;; TODO: Use 'load-compiled'.
(for-each primitive-load '#$actions)))))) (for-each primitive-load '#$actions)))))
(define (gexps->activation-gexp gexps) (define (gexps->activation-gexp gexps)
"Return a gexp that runs the activation script containing GEXPS." "Return a gexp that runs the activation script containing GEXPS."

416
gnu/services/base.scm
View file

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

2
gnu/system/image.scm
View file

@ -141,7 +141,7 @@
(match (package-transitive-propagated-inputs package) (match (package-transitive-propagated-inputs package)
(((labels packages) ...) (((labels packages) ...)
packages)))) packages))))
(list guile-gcrypt guile-sqlite3 guile-zlib))) (list guile-gcrypt guile-sqlite3)))
(define-syntax-rule (with-imported-modules* gexp* ...) (define-syntax-rule (with-imported-modules* gexp* ...)
(with-extensions gcrypt-sqlite3&co (with-extensions gcrypt-sqlite3&co

12
gnu/system/shadow.scm
View file

@ -34,7 +34,6 @@
#:use-module ((gnu packages admin) #:use-module ((gnu packages admin)
#:select (shadow)) #:select (shadow))
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages guile)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
@ -325,12 +324,11 @@ accounts among ACCOUNTS+GROUPS."
(start (with-imported-modules (source-module-closure (start (with-imported-modules (source-module-closure
'((gnu build activation) '((gnu build activation)
(gnu system accounts))) (gnu system accounts)))
(with-extensions (list guile-zlib) #~(lambda ()
#~(lambda () (activate-user-home
(activate-user-home (map sexp->user-account
(map sexp->user-account (list #$@(map user-account->gexp accounts))))
(list #$@(map user-account->gexp accounts)))) #t))) ;success
#t)))) ;success
(documentation "Create user home directories.")))) (documentation "Create user home directories."))))
(define (shells-file shells) (define (shells-file shells)