[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
07/08: services: base: Use 'match-record' instead of 'match'.
|
From: |
guix-commits |
|
Subject: |
07/08: services: base: Use 'match-record' instead of 'match'. |
|
Date: |
Thu, 1 Dec 2022 18:05:49 -0500 (EST) |
civodul pushed a commit to branch master
in repository guix.
commit adfe1064c857fb80f5e1595d254d9691619e2cf2
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Nov 19 17:54:26 2022 +0100
services: base: Use 'match-record' instead of 'match'.
* gnu/services/base.scm (agetty-shepherd-service)
(mingetty-shepherd-service)
(nscd.conf-file)
(udev-shepherd-service)
(udev-etc)
(gpm-shepherd-service)
(network-set-up/linux)
(network-tear-down/linux)
(static-networking-shepherd-service)
(greetd-agreety-tty-session-command)
(greetd-agreety-tty-xdg-session-command): Use 'match-record' instead of
'match'.
(guix-accounts): Use <guix-configuration> accessors.
(udev-service-type): Use <udev-configuration> accessors.
---
gnu/services/base.scm | 922 +++++++++++++++++++++++++-------------------------
1 file changed, 460 insertions(+), 462 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index d99548573d..370696a55e 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -977,148 +977,148 @@ to use as the tty. This is primarily useful for
headless systems."
((device-name _ ...)
device-name))))))))
-(define agetty-shepherd-service
- (match-lambda
- (($ <agetty-configuration> agetty tty term baud-rate auto-login
- login-program login-pause? eight-bits? no-reset? remote? flow-control?
- host no-issue? init-string no-clear? local-line extract-baud?
- skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
- detect-case? wait-cr? no-hints? no-hostname? long-hostname?
- erase-characters kill-characters chdir delay nice extra-options
- shepherd-requirement)
- (list
- (shepherd-service
- (documentation "Run agetty on a tty.")
- (provision (list (symbol-append 'term- (string->symbol (or tty
"console")))))
-
- ;; Since the login prompt shows the host name, wait for the
'host-name'
- ;; service to be done. Also wait for udev essentially so that the tty
- ;; text is not lost in the middle of kernel messages (see also
- ;; mingetty-shepherd-service).
- (requirement (cons* 'user-processes 'host-name 'udev
- shepherd-requirement))
-
- (modules '((ice-9 match) (gnu build linux-boot)))
- (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")
- #~())
+(define (agetty-shepherd-service config)
+ (match-record config <agetty-configuration>
+ (agetty tty term baud-rate auto-login
+ login-program login-pause? eight-bits? no-reset? remote?
flow-control?
+ host no-issue? init-string no-clear? local-line extract-baud?
+ skip-login? no-newline? login-options chroot hangup? keep-baud?
timeout
+ detect-case? wait-cr? no-hints? no-hostname? long-hostname?
+ erase-characters kill-characters chdir delay nice extra-options
+ shepherd-requirement)
+ (list
+ (shepherd-service
+ (documentation "Run agetty on a tty.")
+ (provision (list (symbol-append 'term- (string->symbol (or tty
"console")))))
+
+ ;; Since the login prompt shows the host name, wait for the 'host-name'
+ ;; service to be done. Also wait for udev essentially so that the tty
+ ;; text is not lost in the middle of kernel messages (see also
+ ;; mingetty-shepherd-service).
+ (requirement (cons* 'user-processes 'host-name 'udev
+ shepherd-requirement))
+
+ (modules '((ice-9 match) (gnu build linux-boot)))
+ (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)))))
- (stop #~(make-kill-destructor)))))))
+ #$@(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
(service-type (name 'agetty)
@@ -1148,42 +1148,42 @@ the tty to run, among other things."
(clear-on-logout? mingetty-clear-on-logout? ;Boolean
(default #t)))
-(define mingetty-shepherd-service
- (match-lambda
- (($ <mingetty-configuration> mingetty tty auto-login login-program
- login-pause? clear-on-logout?)
- (list
- (shepherd-service
- (documentation "Run mingetty on an tty.")
- (provision (list (symbol-append 'term- (string->symbol tty))))
-
- ;; Since the login prompt shows the host name, wait for the 'host-name'
- ;; service to be done. Also wait for udev essentially so that the tty
- ;; text is not lost in the middle of kernel messages (XXX).
- (requirement '(user-processes host-name udev virtual-terminal))
-
- (start #~(make-forkexec-constructor
- (list #$(file-append mingetty "/sbin/mingetty")
-
- ;; Avoiding 'vhangup' allows us to avoid 'setfont'
- ;; errors down the path where various ioctls get
- ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
- ;; in Linux.
- "--nohangup" #$tty
-
- #$@(if clear-on-logout?
- #~()
- #~("--noclear"))
- #$@(if auto-login
- #~("--autologin" #$auto-login)
- #~())
- #$@(if login-program
- #~("--loginprog" #$login-program)
- #~())
- #$@(if login-pause?
- #~("--loginpause")
- #~()))))
- (stop #~(make-kill-destructor)))))))
+(define (mingetty-shepherd-service config)
+ (match-record config <mingetty-configuration>
+ (mingetty tty auto-login login-program
+ login-pause? clear-on-logout?)
+ (list
+ (shepherd-service
+ (documentation "Run mingetty on an tty.")
+ (provision (list (symbol-append 'term- (string->symbol tty))))
+
+ ;; Since the login prompt shows the host name, wait for the 'host-name'
+ ;; service to be done. Also wait for udev essentially so that the tty
+ ;; text is not lost in the middle of kernel messages (XXX).
+ (requirement '(user-processes host-name udev virtual-terminal))
+
+ (start #~(make-forkexec-constructor
+ (list #$(file-append mingetty "/sbin/mingetty")
+
+ ;; Avoiding 'vhangup' allows us to avoid 'setfont'
+ ;; errors down the path where various ioctls get
+ ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
+ ;; in Linux.
+ "--nohangup" #$tty
+
+ #$@(if clear-on-logout?
+ #~()
+ #~("--noclear"))
+ #$@(if auto-login
+ #~("--autologin" #$auto-login)
+ #~())
+ #$@(if login-program
+ #~("--loginprog" #$login-program)
+ #~())
+ #$@(if login-pause?
+ #~("--loginpause")
+ #~()))))
+ (stop #~(make-kill-destructor))))))
(define mingetty-service-type
(service-type (name 'mingetty)
@@ -1260,46 +1260,47 @@ the tty to run, among other things."
(define (nscd.conf-file config)
"Return the @file{nscd.conf} configuration file for @var{config}, an
@code{<nscd-configuration>} object."
- (define cache->config
- (match-lambda
- (($ <nscd-cache> (= symbol->string database)
- positive-ttl negative-ttl size check-files?
- persistent? shared? max-size propagate?)
- (string-append "\nenable-cache\t" database "\tyes\n"
-
- "positive-time-to-live\t" database "\t"
- (number->string positive-ttl) "\n"
- "negative-time-to-live\t" database "\t"
- (number->string negative-ttl) "\n"
- "suggested-size\t" database "\t"
- (number->string size) "\n"
- "check-files\t" database "\t"
- (if check-files? "yes\n" "no\n")
- "persistent\t" database "\t"
- (if persistent? "yes\n" "no\n")
- "shared\t" database "\t"
- (if shared? "yes\n" "no\n")
- "max-db-size\t" database "\t"
- (number->string max-size) "\n"
- "auto-propagate\t" database "\t"
- (if propagate? "yes\n" "no\n")))))
-
- (match config
- (($ <nscd-configuration> log-file debug-level caches)
- (plain-file "nscd.conf"
- (string-append "\
+ (define (cache->config cache)
+ (match-record cache <nscd-cache>
+ (database positive-time-to-live negative-time-to-live
+ suggested-size check-files?
+ persistent? shared? max-database-size auto-propagate?)
+ (let ((database (symbol->string database)))
+ (string-append "\nenable-cache\t" database "\tyes\n"
+
+ "positive-time-to-live\t" database "\t"
+ (number->string positive-time-to-live) "\n"
+ "negative-time-to-live\t" database "\t"
+ (number->string negative-time-to-live) "\n"
+ "suggested-size\t" database "\t"
+ (number->string suggested-size) "\n"
+ "check-files\t" database "\t"
+ (if check-files? "yes\n" "no\n")
+ "persistent\t" database "\t"
+ (if persistent? "yes\n" "no\n")
+ "shared\t" database "\t"
+ (if shared? "yes\n" "no\n")
+ "max-db-size\t" database "\t"
+ (number->string max-database-size) "\n"
+ "auto-propagate\t" database "\t"
+ (if auto-propagate? "yes\n" "no\n")))))
+
+ (match-record config <nscd-configuration>
+ (log-file debug-level caches)
+ (plain-file "nscd.conf"
+ (string-append "\
# Configuration of libc's name service cache daemon (nscd).\n\n"
- (if log-file
- (string-append "logfile\t" log-file)
- "")
- "\n"
- (if debug-level
- (string-append "debug-level\t"
- (number->string
debug-level))
- "")
- "\n"
- (string-concatenate
- (map cache->config caches)))))))
+ (if log-file
+ (string-append "logfile\t" log-file)
+ "")
+ "\n"
+ (if debug-level
+ (string-append "debug-level\t"
+ (number->string debug-level))
+ "")
+ "\n"
+ (string-concatenate
+ (map cache->config caches))))))
(define (nscd-action-procedure nscd config option)
;; XXX: This is duplicated from mcron; factorize.
@@ -1797,17 +1798,15 @@ proxy of 'guix-daemon'...~%")
(define (guix-accounts config)
"Return the user accounts and user groups for CONFIG."
- (match config
- (($ <guix-configuration> _ build-group build-accounts)
- (cons (user-group
- (name build-group)
- (system? #t)
-
- ;; Use a fixed GID so that we can create the store with the right
- ;; owner.
- (id 30000))
- (guix-build-accounts build-accounts
- #:group build-group)))))
+ (cons (user-group
+ (name (guix-configuration-build-group config))
+ (system? #t)
+
+ ;; Use a fixed GID so that we can create the store with the right
+ ;; owner.
+ (id 30000))
+ (guix-build-accounts (guix-configuration-build-accounts config)
+ #:group (guix-configuration-build-group config))))
(define (guix-activation config)
"Return the activation gexp for CONFIG."
@@ -2130,95 +2129,94 @@ item of @var{packages}."
(udev-rule "90-kvm.rules"
"KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
-(define udev-shepherd-service
+(define (udev-shepherd-service config)
;; Return a <shepherd-service> for UDEV with RULES.
- (match-lambda
- (($ <udev-configuration> udev)
- (list
- (shepherd-service
- (provision '(udev))
-
- ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
- ;; be added: see
- ;;
<http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
- (requirement '(root-file-system))
-
- (documentation "Populate the /dev directory, dynamically.")
- (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.
- "UDEV_CONFIG_FILE=/etc/udev/udev.conf"
- "EUDEV_RULES_DIRECTORY=/etc/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
- ;; 'user-processes', i.e., before its own 'stop' method was called.
- ;; Thus, make sure it is not respawned.
- (respawn? #f)
- ;; We need additional modules.
- (modules `((gnu build linux-boot) ;'make-static-device-nodes'
- ,@%default-modules)))))))
+ (let ((udev (udev-configuration-udev config)))
+ (list
+ (shepherd-service
+ (provision '(udev))
+
+ ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
+ ;; be added: see
+ ;;
<http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
+ (requirement '(root-file-system))
+
+ (documentation "Populate the /dev directory, dynamically.")
+ (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.
+ "UDEV_CONFIG_FILE=/etc/udev/udev.conf"
+ "EUDEV_RULES_DIRECTORY=/etc/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
+ ;; 'user-processes', i.e., before its own 'stop' method was called.
+ ;; Thus, make sure it is not respawned.
+ (respawn? #f)
+ ;; We need additional modules.
+ (modules `((gnu build linux-boot) ;'make-static-device-nodes'
+ ,@%default-modules))))))
(define udev.conf
(computed-file "udev.conf"
@@ -2226,14 +2224,15 @@ item of @var{packages}."
(lambda (port)
(format port "udev_rules=\"/etc/udev/rules.d\"~%")))))
-(define udev-etc
- (match-lambda
- (($ <udev-configuration> udev rules)
- `(("udev"
- ,(file-union
- "udev" `(("udev.conf" ,udev.conf)
- ("rules.d" ,(udev-rules-union (cons* udev kvm-udev-rule
- rules))))))))))
+(define (udev-etc config)
+ (match-record config <udev-configuration>
+ (udev rules)
+ `(("udev"
+ ,(file-union "udev"
+ `(("udev.conf" ,udev.conf)
+ ("rules.d"
+ ,(udev-rules-union (cons* udev kvm-udev-rule
+ rules)))))))))
(define udev-service-type
(service-type (name 'udev)
@@ -2243,11 +2242,11 @@ item of @var{packages}."
(service-extension etc-service-type udev-etc)))
(compose concatenate) ;concatenate the list of rules
(extend (lambda (config rules)
- (match config
- (($ <udev-configuration> udev initial-rules)
- (udev-configuration
- (udev udev)
- (rules (append initial-rules rules)))))))
+ (let ((initial-rules
+ (udev-configuration-rules config)))
+ (udev-configuration
+ (inherit config)
+ (rules (append initial-rules rules))))))
(default-value (udev-configuration))
(description
"Run @command{udev}, which populates the @file{/dev}
@@ -2385,23 +2384,23 @@ instance."
(options gpm-configuration-options ;list of strings
(default %default-gpm-options)))
-(define gpm-shepherd-service
- (match-lambda
- (($ <gpm-configuration> gpm options)
- (list (shepherd-service
- (requirement '(udev))
- (provision '(gpm))
- ;; 'gpm' runs in the background and sets a PID file.
- ;; Note that it requires running as "root".
- (start #~(make-forkexec-constructor
- (list #$(file-append gpm "/sbin/gpm")
- #$@options)
- #:pid-file "/var/run/gpm.pid"
- #:pid-file-timeout 3))
- (stop #~(lambda (_)
- ;; Return #f if successfully stopped.
- (not (zero? (system* #$(file-append gpm "/sbin/gpm")
- "-k"))))))))))
+(define (gpm-shepherd-service config)
+ (match-record config <gpm-configuration>
+ (gpm options)
+ (list (shepherd-service
+ (requirement '(udev))
+ (provision '(gpm))
+ ;; 'gpm' runs in the background and sets a PID file.
+ ;; Note that it requires running as "root".
+ (start #~(make-forkexec-constructor
+ (list #$(file-append gpm "/sbin/gpm")
+ #$@options)
+ #:pid-file "/var/run/gpm.pid"
+ #:pid-file-timeout 3))
+ (stop #~(lambda (_)
+ ;; Return #f if successfully stopped.
+ (not (zero? (system* #$(file-append gpm "/sbin/gpm")
+ "-k")))))))))
(define gpm-service-type
(service-type (name 'gpm)
@@ -2654,32 +2653,64 @@ to CONFIG."
"/servers/socket/2")
#f))))
-(define network-set-up/linux
- (match-lambda
- (($ <static-networking> addresses links routes)
- (scheme-file "set-up-network"
- (with-extensions (list guile-netlink)
- #~(begin
- (use-modules (ip addr) (ip link) (ip route))
-
- #$@(map (lambda (address)
- #~(begin
- (addr-add #$(network-address-device
address)
- #$(network-address-value
address)
- #:ipv6?
- #$(network-address-ipv6?
address))
- ;; FIXME: loopback?
- (link-set #$(network-address-device
address)
- #:multicast-on #t
- #:up #t)))
- addresses)
- #$@(map (match-lambda
- (($ <network-link> name type arguments)
- #~(link-add #$name #$type
- #:type-args '#$arguments)))
- links)
- #$@(map (lambda (route)
- #~(route-add #$(network-route-destination
route)
+(define (network-set-up/linux config)
+ (match-record config <static-networking>
+ (addresses links routes)
+ (scheme-file "set-up-network"
+ (with-extensions (list guile-netlink)
+ #~(begin
+ (use-modules (ip addr) (ip link) (ip route))
+
+ #$@(map (lambda (address)
+ #~(begin
+ (addr-add #$(network-address-device
address)
+ #$(network-address-value
address)
+ #:ipv6?
+ #$(network-address-ipv6?
address))
+ ;; FIXME: loopback?
+ (link-set #$(network-address-device
address)
+ #:multicast-on #t
+ #:up #t)))
+ addresses)
+ #$@(map (match-lambda
+ (($ <network-link> name type arguments)
+ #~(link-add #$name #$type
+ #:type-args '#$arguments)))
+ links)
+ #$@(map (lambda (route)
+ #~(route-add #$(network-route-destination
route)
+ #:device
+ #$(network-route-device route)
+ #:ipv6?
+ #$(network-route-ipv6? route)
+ #:via
+ #$(network-route-gateway route)
+ #:src
+ #$(network-route-source route)))
+ routes)
+ #t)))))
+
+(define (network-tear-down/linux config)
+ (match-record config <static-networking>
+ (addresses links routes)
+ (scheme-file "tear-down-network"
+ (with-extensions (list guile-netlink)
+ #~(begin
+ (use-modules (ip addr) (ip link) (ip route)
+ (netlink error)
+ (srfi srfi-34))
+
+ (define-syntax-rule (false-if-netlink-error exp)
+ (guard (c ((netlink-error? c) #f))
+ exp))
+
+ ;; Wrap calls in 'false-if-netlink-error' so this
+ ;; script goes as far as possible undoing the effects
+ ;; of "set-up-network".
+
+ #$@(map (lambda (route)
+ #~(false-if-netlink-error
+ (route-del #$(network-route-destination
route)
#:device
#$(network-route-device route)
#:ipv6?
@@ -2687,80 +2718,47 @@ to CONFIG."
#:via
#$(network-route-gateway route)
#:src
- #$(network-route-source route)))
- routes)
- #t))))))
-
-(define network-tear-down/linux
- (match-lambda
- (($ <static-networking> addresses links routes)
- (scheme-file "tear-down-network"
- (with-extensions (list guile-netlink)
- #~(begin
- (use-modules (ip addr) (ip link) (ip route)
- (netlink error)
- (srfi srfi-34))
-
- (define-syntax-rule (false-if-netlink-error exp)
- (guard (c ((netlink-error? c) #f))
- exp))
-
- ;; Wrap calls in 'false-if-netlink-error' so this
- ;; script goes as far as possible undoing the effects
- ;; of "set-up-network".
-
- #$@(map (lambda (route)
- #~(false-if-netlink-error
- (route-del #$(network-route-destination
route)
- #:device
- #$(network-route-device route)
- #:ipv6?
- #$(network-route-ipv6? route)
- #:via
- #$(network-route-gateway route)
- #:src
- #$(network-route-source
route))))
- routes)
- #$@(map (match-lambda
- (($ <network-link> name type arguments)
- #~(false-if-netlink-error
- (link-del #$name))))
- links)
- #$@(map (lambda (address)
+ #$(network-route-source
route))))
+ routes)
+ #$@(map (match-lambda
+ (($ <network-link> name type arguments)
#~(false-if-netlink-error
- (addr-del #$(network-address-device
- address)
- #$(network-address-value
address)
- #:ipv6?
- #$(network-address-ipv6?
address))))
- addresses)
- #f))))))
+ (link-del #$name))))
+ links)
+ #$@(map (lambda (address)
+ #~(false-if-netlink-error
+ (addr-del #$(network-address-device
+ address)
+ #$(network-address-value address)
+ #:ipv6?
+ #$(network-address-ipv6?
address))))
+ addresses)
+ #f)))))
(define (static-networking-shepherd-service config)
- (match config
- (($ <static-networking> addresses links routes
- provision requirement name-servers)
- (let ((loopback? (and provision (memq 'loopback provision))))
- (shepherd-service
+ (match-record config <static-networking>
+ (addresses links routes provision requirement name-servers)
+ (let ((loopback? (and provision (memq 'loopback provision))))
+ (shepherd-service
- (documentation
- "Bring up the networking interface using a static IP address.")
- (requirement requirement)
- (provision provision)
+ (documentation
+ "Bring up the networking interface using a static IP address.")
+ (requirement requirement)
+ (provision provision)
- (start #~(lambda _
- ;; Return #t if successfully started.
- (load #$(let-system (system target)
- (if (string-contains (or target system) "-linux")
- (network-set-up/linux config)
- (network-set-up/hurd config))))))
- (stop #~(lambda _
- ;; Return #f is successfully stopped.
+ (start #~(lambda _
+ ;; Return #t if successfully started.
(load #$(let-system (system target)
(if (string-contains (or target system) "-linux")
- (network-tear-down/linux config)
- (network-tear-down/hurd config))))))
- (respawn? #f))))))
+ (network-set-up/linux config)
+ (network-set-up/hurd config))))))
+ (stop #~(lambda _
+ ;; Return #f is successfully stopped.
+ (load #$(let-system (system target)
+ (if (string-contains (or target system) "-linux")
+ (network-tear-down/linux config)
+ (network-tear-down/hurd config))))))
+ (respawn? #f)))))
(define (static-networking-shepherd-services networks)
(map static-networking-shepherd-service networks))
@@ -2873,33 +2871,33 @@ to handle."
(extra-env greetd-agreety-extra-env (default '()))
(xdg-env? greetd-agreety-xdg-env? (default #t)))
-(define greetd-agreety-tty-session-command
- (match-lambda
- (($ <greetd-agreety-session> _ command args extra-env)
- (program-file
- "agreety-tty-session-command"
- #~(begin
- (use-modules (ice-9 match))
- (for-each (match-lambda ((var . val) (setenv var val)))
- (quote (#$@extra-env)))
- (apply execl #$command #$command (list #$@args)))))))
-
-(define greetd-agreety-tty-xdg-session-command
- (match-lambda
- (($ <greetd-agreety-session> _ command args extra-env)
- (program-file
- "agreety-tty-xdg-session-command"
- #~(begin
- (use-modules (ice-9 match))
- (let*
- ((username (getenv "USER"))
- (useruid (passwd:uid (getpwuid username)))
- (useruid (number->string useruid)))
- (setenv "XDG_SESSION_TYPE" "tty")
- (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)))
- (for-each (match-lambda ((var . val) (setenv var val)))
- (quote (#$@extra-env)))
- (apply execl #$command #$command (list #$@args)))))))
+(define (greetd-agreety-tty-session-command config)
+ (match-record config <greetd-agreety-session>
+ (command command-args extra-env)
+ (program-file
+ "agreety-tty-session-command"
+ #~(begin
+ (use-modules (ice-9 match))
+ (for-each (match-lambda ((var . val) (setenv var val)))
+ (quote (#$@extra-env)))
+ (apply execl #$command #$command (list #$@command-args))))))
+
+(define (greetd-agreety-tty-xdg-session-command config)
+ (match-record config <greetd-agreety-session>
+ (command command-args extra-env)
+ (program-file
+ "agreety-tty-xdg-session-command"
+ #~(begin
+ (use-modules (ice-9 match))
+ (let*
+ ((username (getenv "USER"))
+ (useruid (passwd:uid (getpwuid username)))
+ (useruid (number->string useruid)))
+ (setenv "XDG_SESSION_TYPE" "tty")
+ (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)))
+ (for-each (match-lambda ((var . val) (setenv var val)))
+ (quote (#$@extra-env)))
+ (apply execl #$command #$command (list #$@command-args))))))
(define-gexp-compiler (greetd-agreety-session-compiler
(session <greetd-agreety-session>)
- branch master updated (c7793b82ef -> 00ddf185e6), guix-commits, 2022/12/01
- 04/08: records: 'match-record' checks fields at macro-expansion time., guix-commits, 2022/12/01
- 02/08: etc: teams: Add chez.scm to Racket team's scope., guix-commits, 2022/12/01
- 05/08: doc: Recommend 'match-record'., guix-commits, 2022/12/01
- 01/08: gnu: guile-gcrypt: Update to 0.4.0., guix-commits, 2022/12/01
- 06/08: home: services: Use 'match-record' instead of 'match'., guix-commits, 2022/12/01
- 07/08: services: base: Use 'match-record' instead of 'match'.,
guix-commits <=
- 03/08: gnu: Add alfa., guix-commits, 2022/12/01
- 08/08: services: networking: Avoid 'match' on records., guix-commits, 2022/12/01