me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2022-11-19 17:54:26 +01:00
parent 4c8eea027a
commit adfe1064c8
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 440 additions and 442 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
gnu/services/base.scm
View File

@ -977,9 +977,9 @@ 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
(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
@ -1118,7 +1118,7 @@ to use as the tty. This is primarily useful for headless systems."
#~())))
(const #f)) ; never start.
args)))))
(stop #~(make-kill-destructor)))))))
(stop #~(make-kill-destructor))))))
(define agetty-service-type
(service-type (name 'agetty)
@ -1148,9 +1148,9 @@ 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
(define (mingetty-shepherd-service config)
(match-record config <mingetty-configuration>
(mingetty tty auto-login login-program
login-pause? clear-on-logout?)
(list
(shepherd-service
@ -1183,7 +1183,7 @@ the tty to run, among other things."
#$@(if login-pause?
#~("--loginpause")
#~()))))
(stop #~(make-kill-destructor)))))))
(stop #~(make-kill-destructor))))))
(define mingetty-service-type
(service-type (name 'mingetty)
@ -1260,19 +1260,20 @@ 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?)
(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-ttl) "\n"
(number->string positive-time-to-live) "\n"
"negative-time-to-live\t" database "\t"
(number->string negative-ttl) "\n"
(number->string negative-time-to-live) "\n"
"suggested-size\t" database "\t"
(number->string size) "\n"
(number->string suggested-size) "\n"
"check-files\t" database "\t"
(if check-files? "yes\n" "no\n")
"persistent\t" database "\t"
@ -1280,12 +1281,12 @@ the tty to run, among other things."
"shared\t" database "\t"
(if shared? "yes\n" "no\n")
"max-db-size\t" database "\t"
(number->string max-size) "\n"
(number->string max-database-size) "\n"
"auto-propagate\t" database "\t"
(if propagate? "yes\n" "no\n")))))
(if auto-propagate? "yes\n" "no\n")))))
(match config
(($ <nscd-configuration> log-file debug-level caches)
(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"
@ -1299,7 +1300,7 @@ the tty to run, among other things."
"")
"\n"
(string-concatenate
(map cache->config caches)))))))
(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)
(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 build-accounts
#:group build-group)))))
(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,10 +2129,9 @@ 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)
(let ((udev (udev-configuration-udev config)))
(list
(shepherd-service
(provision '(udev))
@ -2218,7 +2216,7 @@ item of @var{packages}."
(respawn? #f)
;; We need additional modules.
(modules `((gnu build linux-boot) ;'make-static-device-nodes'
,@%default-modules)))))))
,@%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)
(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))))))))))
,(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)
(let ((initial-rules
(udev-configuration-rules config)))
(udev-configuration
(udev udev)
(rules (append initial-rules rules)))))))
(inherit config)
(rules (append initial-rules rules))))))
(default-value (udev-configuration))
(description
"Run @command{udev}, which populates the @file{/dev}
@ -2385,9 +2384,9 @@ instance."
(options gpm-configuration-options ;list of strings
(default %default-gpm-options)))
(define gpm-shepherd-service
(match-lambda
(($ <gpm-configuration> gpm options)
(define (gpm-shepherd-service config)
(match-record config <gpm-configuration>
(gpm options)
(list (shepherd-service
(requirement '(udev))
(provision '(gpm))
@ -2401,7 +2400,7 @@ instance."
(stop #~(lambda (_)
;; Return #f if successfully stopped.
(not (zero? (system* #$(file-append gpm "/sbin/gpm")
"-k"))))))))))
"-k")))))))))
(define gpm-service-type
(service-type (name 'gpm)
@ -2654,9 +2653,9 @@ to CONFIG."
"/servers/socket/2")
#f))))
(define network-set-up/linux
(match-lambda
(($ <static-networking> addresses links routes)
(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
@ -2689,11 +2688,11 @@ to CONFIG."
#:src
#$(network-route-source route)))
routes)
#t))))))
#t)))))
(define network-tear-down/linux
(match-lambda
(($ <static-networking> addresses links routes)
(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
@ -2734,12 +2733,11 @@ to CONFIG."
#:ipv6?
#$(network-address-ipv6? address))))
addresses)
#f))))))
#f)))))
(define (static-networking-shepherd-service config)
(match config
(($ <static-networking> addresses links routes
provision requirement name-servers)
(match-record config <static-networking>
(addresses links routes provision requirement name-servers)
(let ((loopback? (and provision (memq 'loopback provision))))
(shepherd-service
@ -2760,7 +2758,7 @@ to CONFIG."
(if (string-contains (or target system) "-linux")
(network-tear-down/linux config)
(network-tear-down/hurd config))))))
(respawn? #f))))))
(respawn? #f)))))
(define (static-networking-shepherd-services networks)
(map static-networking-shepherd-service networks))
@ -2873,20 +2871,20 @@ 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)
(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 #$@args)))))))
(apply execl #$command #$command (list #$@command-args))))))
(define greetd-agreety-tty-xdg-session-command
(match-lambda
(($ <greetd-agreety-session> _ command args extra-env)
(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
@ -2899,7 +2897,7 @@ to handle."
(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)))))))
(apply execl #$command #$command (list #$@command-args))))))
(define-gexp-compiler (greetd-agreety-session-compiler
(session <greetd-agreety-session>)