me/guix
Archived
1
0
Fork 0
Code Activity

services: base: Use 'match-record' instead of 'match'.

Browse source 
* 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.
This commit is contained in:
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 _ ...)
device-name)))))))) device-name))))))))
(define agetty-shepherd-service (define (agetty-shepherd-service config)
(match-lambda (match-record config <agetty-configuration>
(($ <agetty-configuration> agetty tty term baud-rate auto-login (agetty tty term baud-rate auto-login
login-program login-pause? eight-bits? no-reset? remote? flow-control? login-program login-pause? eight-bits? no-reset? remote? flow-control?
host no-issue? init-string no-clear? local-line extract-baud? host no-issue? init-string no-clear? local-line extract-baud?
skip-login? no-newline? login-options chroot hangup? keep-baud? timeout 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. (const #f)) ; never start.
args))))) args)))))
(stop #~(make-kill-destructor))))))) (stop #~(make-kill-destructor))))))
(define agetty-service-type (define agetty-service-type
(service-type (name 'agetty) (service-type (name 'agetty)
@ -1148,9 +1148,9 @@ the tty to run, among other things."
(clear-on-logout? mingetty-clear-on-logout? ;Boolean (clear-on-logout? mingetty-clear-on-logout? ;Boolean
(default #t))) (default #t)))
(define mingetty-shepherd-service (define (mingetty-shepherd-service config)
(match-lambda (match-record config <mingetty-configuration>
(($ <mingetty-configuration> mingetty tty auto-login login-program (mingetty tty auto-login login-program
login-pause? clear-on-logout?) login-pause? clear-on-logout?)
(list (list
(shepherd-service (shepherd-service
@ -1183,7 +1183,7 @@ the tty to run, among other things."
#$@(if login-pause? #$@(if login-pause?
#~("--loginpause") #~("--loginpause")
#~())))) #~()))))
(stop #~(make-kill-destructor))))))) (stop #~(make-kill-destructor))))))
(define mingetty-service-type (define mingetty-service-type
(service-type (name 'mingetty) (service-type (name 'mingetty)
@ -1260,19 +1260,20 @@ the tty to run, among other things."
(define (nscd.conf-file config) (define (nscd.conf-file config)
"Return the @file{nscd.conf} configuration file for @var{config}, an "Return the @file{nscd.conf} configuration file for @var{config}, an
@code{<nscd-configuration>} object." @code{<nscd-configuration>} object."
(define cache->config (define (cache->config cache)
(match-lambda (match-record cache <nscd-cache>
(($ <nscd-cache> (= symbol->string database) (database positive-time-to-live negative-time-to-live
positive-ttl negative-ttl size check-files? suggested-size check-files?
persistent? shared? max-size propagate?) persistent? shared? max-database-size auto-propagate?)
(let ((database (symbol->string database)))
(string-append "\nenable-cache\t" database "\tyes\n" (string-append "\nenable-cache\t" database "\tyes\n"
"positive-time-to-live\t" database "\t" "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" "negative-time-to-live\t" database "\t"
(number->string negative-ttl) "\n" (number->string negative-time-to-live) "\n"
"suggested-size\t" database "\t" "suggested-size\t" database "\t"
(number->string size) "\n" (number->string suggested-size) "\n"
"check-files\t" database "\t" "check-files\t" database "\t"
(if check-files? "yes\n" "no\n") (if check-files? "yes\n" "no\n")
"persistent\t" database "\t" "persistent\t" database "\t"
@ -1280,12 +1281,12 @@ the tty to run, among other things."
"shared\t" database "\t" "shared\t" database "\t"
(if shared? "yes\n" "no\n") (if shared? "yes\n" "no\n")
"max-db-size\t" database "\t" "max-db-size\t" database "\t"
(number->string max-size) "\n" (number->string max-database-size) "\n"
"auto-propagate\t" database "\t" "auto-propagate\t" database "\t"
(if propagate? "yes\n" "no\n"))))) (if auto-propagate? "yes\n" "no\n")))))
(match config (match-record config <nscd-configuration>
(($ <nscd-configuration> log-file debug-level caches) (log-file debug-level caches)
(plain-file "nscd.conf" (plain-file "nscd.conf"
(string-append "\ (string-append "\
# Configuration of libc's name service cache daemon (nscd).\n\n" # Configuration of libc's name service cache daemon (nscd).\n\n"
@ -1299,7 +1300,7 @@ the tty to run, among other things."
"") "")
"\n" "\n"
(string-concatenate (string-concatenate
(map cache->config caches))))))) (map cache->config caches))))))
(define (nscd-action-procedure nscd config option) (define (nscd-action-procedure nscd config option)
;; XXX: This is duplicated from mcron; factorize. ;; XXX: This is duplicated from mcron; factorize.
@ -1797,17 +1798,15 @@ proxy of 'guix-daemon'...~%")
(define (guix-accounts config) (define (guix-accounts config)
"Return the user accounts and user groups for CONFIG." "Return the user accounts and user groups for CONFIG."
(match config
(($ <guix-configuration> _ build-group build-accounts)
(cons (user-group (cons (user-group
(name build-group) (name (guix-configuration-build-group config))
(system? #t) (system? #t)
;; Use a fixed GID so that we can create the store with the right ;; Use a fixed GID so that we can create the store with the right
;; owner. ;; owner.
(id 30000)) (id 30000))
(guix-build-accounts build-accounts (guix-build-accounts (guix-configuration-build-accounts config)
#:group build-group))))) #:group (guix-configuration-build-group config))))
(define (guix-activation config) (define (guix-activation config)
"Return the activation gexp for CONFIG." "Return the activation gexp for CONFIG."
@ -2130,10 +2129,9 @@ item of @var{packages}."
(udev-rule "90-kvm.rules" (udev-rule "90-kvm.rules"
"KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n")) "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
(define udev-shepherd-service (define (udev-shepherd-service config)
;; Return a <shepherd-service> for UDEV with RULES. ;; Return a <shepherd-service> for UDEV with RULES.
(match-lambda (let ((udev (udev-configuration-udev config)))
(($ <udev-configuration> udev)
(list (list
(shepherd-service (shepherd-service
(provision '(udev)) (provision '(udev))
@ -2218,7 +2216,7 @@ item of @var{packages}."
(respawn? #f) (respawn? #f)
;; We need additional modules. ;; We need additional modules.
(modules `((gnu build linux-boot) ;'make-static-device-nodes' (modules `((gnu build linux-boot) ;'make-static-device-nodes'
,@%default-modules))))))) ,@%default-modules))))))
(define udev.conf (define udev.conf
(computed-file "udev.conf" (computed-file "udev.conf"
@ -2226,14 +2224,15 @@ item of @var{packages}."
(lambda (port) (lambda (port)
(format port "udev_rules=\"/etc/udev/rules.d\"~%"))))) (format port "udev_rules=\"/etc/udev/rules.d\"~%")))))
(define udev-etc (define (udev-etc config)
(match-lambda (match-record config <udev-configuration>
(($ <udev-configuration> udev rules) (udev rules)
`(("udev" `(("udev"
,(file-union ,(file-union "udev"
"udev" `(("udev.conf" ,udev.conf) `(("udev.conf" ,udev.conf)
("rules.d" ,(udev-rules-union (cons* udev kvm-udev-rule ("rules.d"
rules)))))))))) ,(udev-rules-union (cons* udev kvm-udev-rule
rules)))))))))
(define udev-service-type (define udev-service-type
(service-type (name 'udev) (service-type (name 'udev)
@ -2243,11 +2242,11 @@ item of @var{packages}."
(service-extension etc-service-type udev-etc))) (service-extension etc-service-type udev-etc)))
(compose concatenate) ;concatenate the list of rules (compose concatenate) ;concatenate the list of rules
(extend (lambda (config rules) (extend (lambda (config rules)
(match config (let ((initial-rules
(($ <udev-configuration> udev initial-rules) (udev-configuration-rules config)))
(udev-configuration (udev-configuration
(udev udev) (inherit config)
(rules (append initial-rules rules))))))) (rules (append initial-rules rules))))))
(default-value (udev-configuration)) (default-value (udev-configuration))
(description (description
"Run @command{udev}, which populates the @file{/dev} "Run @command{udev}, which populates the @file{/dev}
@ -2385,9 +2384,9 @@ instance."
(options gpm-configuration-options ;list of strings (options gpm-configuration-options ;list of strings
(default %default-gpm-options))) (default %default-gpm-options)))
(define gpm-shepherd-service (define (gpm-shepherd-service config)
(match-lambda (match-record config <gpm-configuration>
(($ <gpm-configuration> gpm options) (gpm options)
(list (shepherd-service (list (shepherd-service
(requirement '(udev)) (requirement '(udev))
(provision '(gpm)) (provision '(gpm))
@ -2401,7 +2400,7 @@ instance."
(stop #~(lambda (_) (stop #~(lambda (_)
;; Return #f if successfully stopped. ;; Return #f if successfully stopped.
(not (zero? (system* #$(file-append gpm "/sbin/gpm") (not (zero? (system* #$(file-append gpm "/sbin/gpm")
"-k")))))))))) "-k")))))))))
(define gpm-service-type (define gpm-service-type
(service-type (name 'gpm) (service-type (name 'gpm)
@ -2654,9 +2653,9 @@ to CONFIG."
"/servers/socket/2") "/servers/socket/2")
#f)))) #f))))
(define network-set-up/linux (define (network-set-up/linux config)
(match-lambda (match-record config <static-networking>
(($ <static-networking> addresses links routes) (addresses links routes)
(scheme-file "set-up-network" (scheme-file "set-up-network"
(with-extensions (list guile-netlink) (with-extensions (list guile-netlink)
#~(begin #~(begin
@ -2689,11 +2688,11 @@ to CONFIG."
#:src #:src
#$(network-route-source route))) #$(network-route-source route)))
routes) routes)
#t)))))) #t)))))
(define network-tear-down/linux (define (network-tear-down/linux config)
(match-lambda (match-record config <static-networking>
(($ <static-networking> addresses links routes) (addresses links routes)
(scheme-file "tear-down-network" (scheme-file "tear-down-network"
(with-extensions (list guile-netlink) (with-extensions (list guile-netlink)
#~(begin #~(begin
@ -2734,12 +2733,11 @@ to CONFIG."
#:ipv6? #:ipv6?
#$(network-address-ipv6? address)))) #$(network-address-ipv6? address))))
addresses) addresses)
#f)))))) #f)))))
(define (static-networking-shepherd-service config) (define (static-networking-shepherd-service config)
(match config (match-record config <static-networking>
(($ <static-networking> addresses links routes (addresses links routes provision requirement name-servers)
provision requirement name-servers)
(let ((loopback? (and provision (memq 'loopback provision)))) (let ((loopback? (and provision (memq 'loopback provision))))
(shepherd-service (shepherd-service
@ -2760,7 +2758,7 @@ to CONFIG."
(if (string-contains (or target system) "-linux") (if (string-contains (or target system) "-linux")
(network-tear-down/linux config) (network-tear-down/linux config)
(network-tear-down/hurd config)))))) (network-tear-down/hurd config))))))
(respawn? #f)))))) (respawn? #f)))))
(define (static-networking-shepherd-services networks) (define (static-networking-shepherd-services networks)
(map static-networking-shepherd-service networks)) (map static-networking-shepherd-service networks))
@ -2873,20 +2871,20 @@ to handle."
(extra-env greetd-agreety-extra-env (default '())) (extra-env greetd-agreety-extra-env (default '()))
(xdg-env? greetd-agreety-xdg-env? (default #t))) (xdg-env? greetd-agreety-xdg-env? (default #t)))
(define greetd-agreety-tty-session-command (define (greetd-agreety-tty-session-command config)
(match-lambda (match-record config <greetd-agreety-session>
(($ <greetd-agreety-session> _ command args extra-env) (command command-args extra-env)
(program-file (program-file
"agreety-tty-session-command" "agreety-tty-session-command"
#~(begin #~(begin
(use-modules (ice-9 match)) (use-modules (ice-9 match))
(for-each (match-lambda ((var . val) (setenv var val))) (for-each (match-lambda ((var . val) (setenv var val)))
(quote (#$@extra-env))) (quote (#$@extra-env)))
(apply execl #$command #$command (list #$@args))))))) (apply execl #$command #$command (list #$@command-args))))))
(define greetd-agreety-tty-xdg-session-command (define (greetd-agreety-tty-xdg-session-command config)
(match-lambda (match-record config <greetd-agreety-session>
(($ <greetd-agreety-session> _ command args extra-env) (command command-args extra-env)
(program-file (program-file
"agreety-tty-xdg-session-command" "agreety-tty-xdg-session-command"
#~(begin #~(begin
@ -2899,7 +2897,7 @@ to handle."
(setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))) (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)))
(for-each (match-lambda ((var . val) (setenv var val))) (for-each (match-lambda ((var . val) (setenv var val)))
(quote (#$@extra-env))) (quote (#$@extra-env)))
(apply execl #$command #$command (list #$@args))))))) (apply execl #$command #$command (list #$@command-args))))))
(define-gexp-compiler (greetd-agreety-session-compiler (define-gexp-compiler (greetd-agreety-session-compiler
(session <greetd-agreety-session>) (session <greetd-agreety-session>)