* [bug#59390] [PATCH 0/5] Doing 'match-record' work at expansion time
@ 2022-11-19 22:23 Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time Ludovic Courtès
2022-12-01 23:07 ` bug#59390: [PATCH 0/5] Doing 'match-record' work at expansion time Ludovic Courtès
0 siblings, 2 replies; 7+ messages in thread
From: Ludovic Courtès @ 2022-11-19 22:23 UTC (permalink / raw)
To: 59390; +Cc: Ludovic Courtès
Hello Guix!
This addresses a longstanding issue: making ‘match-record’ efficient,
and allowing it to error out on unknown field names are macro-expansion
time.
It does so by changing the record type identifier passed to
‘define-record-type*’ to a macro that can either expand to the actual
record type descriptor (RTD) or provide the list of fields of
this type:
--8<---------------cut here---------------start------------->8---
scheme@(guix records)> (define-record-type* <foo> foo make-foo foo? (one foo-one) (two foo-two))
scheme@(guix records)> <foo>
$89 = #<record-type <foo>>
scheme@(guix records)> ,expand <foo>
$90 = #{% <foo> rtd}#
scheme@(guix records)> ,expand (<foo> map-fields f)
$91 = (f (one two))
scheme@(guix records)> ,optimize (match-record x <foo>
(two one)
(list one two))
$92 = (if (eq? (struct-vtable x) #{% <foo> rtd}#)
(let* ((two (struct-ref x 1)) (one (struct-ref x 0)))
(list one two))
(throw 'wrong-type-arg x))
scheme@(guix records)> ,expand (match-record x <foo>
(xyz)
#f)
While executing meta-command:
Syntax error:
unknown file:12066:34: lookup-field: unknown record type field in subform xyz of (lookup-field xyz (+ 1 (+ 1 0)) ())
--8<---------------cut here---------------end--------------->8---
I changed a few services that were using ‘match’ to use either
‘match-record’ or accessors (the latter when accessing just one
or two fields).
This change breaks the ABI: we’ll have to run:
make clean-go && make
Thoughts?
Ludo’.
Ludovic Courtès (5):
records: 'match-record' checks fields at macro-expansion time.
doc: Recommend 'match-record'.
home: services: Use 'match-record' instead of 'match'.
services: base: Use 'match-record' instead of 'match'.
services: networking: Avoid 'match' on records.
doc/contributing.texi | 7 +-
gnu/home/services/mcron.scm | 58 +--
gnu/home/services/shells.scm | 50 +-
gnu/home/services/xdg.scm | 36 +-
gnu/services/base.scm | 882 +++++++++++++++++------------------
gnu/services/cuirass.scm | 4 +-
gnu/services/getmail.scm | 22 +-
gnu/services/networking.scm | 661 +++++++++++++-------------
guix/records.scm | 87 +++-
tests/records.scm | 33 ++
10 files changed, 967 insertions(+), 873 deletions(-)
base-commit: bb04b5e0ceb606c8d33d53bf06f7fc8855a2c56b
--
2.38.1
^ permalink raw reply [flat|nested] 7+ messages in thread
* [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time.
2022-11-19 22:23 [bug#59390] [PATCH 0/5] Doing 'match-record' work at expansion time Ludovic Courtès
@ 2022-11-19 22:24 ` Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 2/5] doc: Recommend 'match-record' Ludovic Courtès
` (3 more replies)
2022-12-01 23:07 ` bug#59390: [PATCH 0/5] Doing 'match-record' work at expansion time Ludovic Courtès
1 sibling, 4 replies; 7+ messages in thread
From: Ludovic Courtès @ 2022-11-19 22:24 UTC (permalink / raw)
To: 59390; +Cc: Ludovic Courtès
This allows 'match-record' to be more efficient (field offsets are
computed at compilation time) and to report unknown fields at
macro-expansion time.
* guix/records.scm (map-fields): New macro.
(define-record-type*)[rtd-identifier]: New procedure.
Define TYPE as a macro and use a separate identifier for the RTD.
(lookup-field, match-record-inner): New macros.
(match-record): Rewrite in terms of 'match-error-inner'.
* tests/records.scm ("record-match, simple")
("record-match, unknown field"): New tests.
* gnu/services/cuirass.scm (cuirass-shepherd-service): Rename 'log-file'
local variable to 'main-log-file'.
* gnu/services/getmail.scm (serialize-getmail-configuration-file): Move
after <getmail-configuration-file> definition.
---
gnu/services/cuirass.scm | 4 +-
gnu/services/getmail.scm | 22 +++++-----
guix/records.scm | 87 +++++++++++++++++++++++++++++++++++-----
tests/records.scm | 33 +++++++++++++++
4 files changed, 122 insertions(+), 24 deletions(-)
diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
index 52de5ca7c0..d7c6ab9877 100644
--- a/gnu/services/cuirass.scm
+++ b/gnu/services/cuirass.scm
@@ -125,7 +125,7 @@ (define (cuirass-shepherd-service config)
(let ((cuirass (cuirass-configuration-cuirass config))
(cache-directory (cuirass-configuration-cache-directory config))
(web-log-file (cuirass-configuration-web-log-file config))
- (log-file (cuirass-configuration-log-file config))
+ (main-log-file (cuirass-configuration-log-file config))
(user (cuirass-configuration-user config))
(group (cuirass-configuration-group config))
(interval (cuirass-configuration-interval config))
@@ -169,7 +169,7 @@ (define (cuirass-shepherd-service config)
#:user #$user
#:group #$group
- #:log-file #$log-file))
+ #:log-file #$main-log-file))
(stop #~(make-kill-destructor)))
,(shepherd-service
(documentation "Run Cuirass web interface.")
diff --git a/gnu/services/getmail.scm b/gnu/services/getmail.scm
index fb82d054ca..19faea782f 100644
--- a/gnu/services/getmail.scm
+++ b/gnu/services/getmail.scm
@@ -215,17 +215,6 @@ (define-configuration getmail-options-configuration
(parameter-alist '())
"Extra options to include."))
-(define (serialize-getmail-configuration-file field-name val)
- (match-record val <getmail-configuration-file>
- (retriever destination options)
- #~(string-append
- "[retriever]\n"
- #$(serialize-getmail-retriever-configuration #f retriever)
- "\n[destination]\n"
- #$(serialize-getmail-destination-configuration #f destination)
- "\n[options]\n"
- #$(serialize-getmail-options-configuration #f options))))
-
(define-configuration getmail-configuration-file
(retriever
(getmail-retriever-configuration (getmail-retriever-configuration))
@@ -237,6 +226,17 @@ (define-configuration getmail-configuration-file
(getmail-options-configuration (getmail-options-configuration))
"Configure getmail."))
+(define (serialize-getmail-configuration-file field-name val)
+ (match-record val <getmail-configuration-file>
+ (retriever destination options)
+ #~(string-append
+ "[retriever]\n"
+ #$(serialize-getmail-retriever-configuration #f retriever)
+ "\n[destination]\n"
+ #$(serialize-getmail-destination-configuration #f destination)
+ "\n[options]\n"
+ #$(serialize-getmail-options-configuration #f options))))
+
(define (serialize-symbol field-name val) "")
(define (serialize-getmail-configuration field-name val) "")
diff --git a/guix/records.scm b/guix/records.scm
index ed94c83dac..13463647c8 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -104,6 +104,10 @@ (define (report-duplicate-field-specifier name ctor)
(()
#t)))))))
+(define-syntax map-fields
+ (lambda (x)
+ (syntax-violation 'map-fields "bad use of syntactic keyword" x x)))
+
(define-syntax-parameter this-record
(lambda (s)
"Return the record being defined. This macro may only be used in the
@@ -325,6 +329,15 @@ (define-record-type* <thing> thing make-thing
field and its 'loc' field---the latter is marked as \"innate\", so it is not
inherited."
+ (define (rtd-identifier type)
+ ;; Return an identifier derived from TYPE to name its record type
+ ;; descriptor (RTD).
+ (let ((type-name (syntax->datum type)))
+ (datum->syntax
+ type
+ (string->symbol
+ (string-append "% " (symbol->string type-name) " rtd")))))
+
(define (field-default-value s)
(syntax-case s (default)
((field (default val) _ ...)
@@ -428,10 +441,31 @@ (define (compute-abi-cookie field-specs)
field)))
field-spec)))
#`(begin
- (define-record-type type
+ (define-record-type #,(rtd-identifier #'type)
(ctor field ...)
pred
field-spec* ...)
+
+ ;; Rectify the vtable type name...
+ (set-struct-vtable-name! #,(rtd-identifier #'type) 'type)
+ (cond-expand
+ (guile-3
+ ;; ... and the record type name.
+ (struct-set! #,(rtd-identifier #'type) vtable-offset-user
+ 'type))
+ (else #f))
+
+ (define-syntax type
+ (lambda (s)
+ "This macro lets us query record type info at
+macro-expansion time."
+ (syntax-case s (map-fields)
+ ((_ map-fields macro)
+ #'(macro (field ...)))
+ (id
+ (identifier? #'id)
+ #'#,(rtd-identifier #'type)))))
+
(define #,(current-abi-identifier #'type)
#,cookie)
@@ -535,19 +569,50 @@ (define (recutils->alist port)
(else
(error "unmatched line" line))))))))
+\f
+;;;
+;;; Pattern matching.
+;;;
+
+(define-syntax lookup-field
+ (lambda (s)
+ "Look up FIELD in the given list and return an expression that represents
+its offset in the record. Raise a syntax violation when the field is not
+found."
+ (syntax-case s ()
+ ((_ field offset ())
+ (syntax-violation 'lookup-field "unknown record type field"
+ s #'field))
+ ((_ field offset (head tail ...))
+ (free-identifier=? #'field #'head)
+ #'offset)
+ ((_ field offset (_ tail ...))
+ #'(lookup-field field (+ 1 offset) (tail ...))))))
+
+(define-syntax match-record-inner
+ (lambda (s)
+ (syntax-case s ()
+ ((_ record type (field rest ...) body ...)
+ #`(let-syntax ((field-offset (syntax-rules ()
+ ((_ f)
+ (lookup-field field 0 f)))))
+ (let* ((offset (type map-fields field-offset))
+ (field (struct-ref record offset)))
+ (match-record-inner record type (rest ...) body ...))))
+ ((_ record type () body ...)
+ #'(begin body ...)))))
+
(define-syntax match-record
(syntax-rules ()
"Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
+The order in which fields appear does not matter. A syntax error is raised if
+an unknown field is queried.
+
The current implementation does not support thunked and delayed fields."
- ((_ record type (field fields ...) body ...)
+ ;; TODO support thunked and delayed fields
+ ((_ record type (fields ...) body ...)
(if (eq? (struct-vtable record) type)
- ;; TODO compute indices and report wrong-field-name errors at
- ;; expansion time
- ;; TODO support thunked and delayed fields
- (let ((field ((record-accessor type 'field) record)))
- (match-record record type (fields ...) body ...))
- (throw 'wrong-type-arg record)))
- ((_ record type () body ...)
- (begin body ...))))
+ (match-record-inner record type (fields ...) body ...)
+ (throw 'wrong-type-arg record)))))
;;; records.scm ends here
diff --git a/tests/records.scm b/tests/records.scm
index 00c58b0736..76dadb3d48 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -528,4 +528,37 @@ (define (make-me-a-record) (foo)))
'("a" "b" "c")
'("a")))
+(test-equal "record-match, simple"
+ '((1 2) (a b))
+ (let ()
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (first foo-first (default 1))
+ (second foo-second))
+
+ (list (match-record (foo (second 2)) <foo>
+ (first second)
+ (list first second))
+ (match-record (foo (first 'a) (second 'b)) <foo>
+ (second first)
+ (list first second)))))
+
+(test-equal "record-match, unknown field"
+ 'syntax-error
+ (catch 'syntax-error
+ (lambda ()
+ (eval '(begin
+ (use-modules (guix records))
+
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (first foo-first (default 1))
+ (second foo-second))
+
+ (match-record (foo (second 2)) <foo>
+ (one two)
+ #f))
+ (make-fresh-user-module)))
+ (lambda (key . args) key)))
+
(test-end)
--
2.38.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [bug#59390] [PATCH 2/5] doc: Recommend 'match-record'.
2022-11-19 22:24 ` [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time Ludovic Courtès
@ 2022-11-19 22:24 ` Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 3/5] home: services: Use 'match-record' instead of 'match' Ludovic Courtès
` (2 subsequent siblings)
3 siblings, 0 replies; 7+ messages in thread
From: Ludovic Courtès @ 2022-11-19 22:24 UTC (permalink / raw)
To: 59390; +Cc: Ludovic Courtès
* doc/contributing.texi (Data Types and Pattern Matching): Recommend
'match-record'.
---
doc/contributing.texi | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/doc/contributing.texi b/doc/contributing.texi
index 40ae33ecac..6a8ffd6524 100644
--- a/doc/contributing.texi
+++ b/doc/contributing.texi
@@ -1089,11 +1089,16 @@ and then to browse them ``by hand'' using @code{car}, @code{cdr},
notably the fact that it is hard to read, error-prone, and a hindrance
to proper type error reports.
+@findex define-record-type*
+@findex match-record
+@cindex pattern matching
Guix code should define appropriate data types (for instance, using
@code{define-record-type*}) rather than abuse lists. In addition, it
should use pattern matching, via Guile’s @code{(ice-9 match)} module,
especially when matching lists (@pxref{Pattern Matching,,, guile, GNU
-Guile Reference Manual}).
+Guile Reference Manual}); pattern matching for records is better done
+using @code{match-record} from @code{(guix records)}, which, unlike
+@code{match}, verifies field names at macro-expansion time.
@node Formatting Code
@subsection Formatting Code
--
2.38.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [bug#59390] [PATCH 3/5] home: services: Use 'match-record' instead of 'match'.
2022-11-19 22:24 ` [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 2/5] doc: Recommend 'match-record' Ludovic Courtès
@ 2022-11-19 22:24 ` Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 4/5] services: base: " Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 5/5] services: networking: Avoid 'match' on records Ludovic Courtès
3 siblings, 0 replies; 7+ messages in thread
From: Ludovic Courtès @ 2022-11-19 22:24 UTC (permalink / raw)
To: 59390; +Cc: Ludovic Courtès
* gnu/home/services/mcron.scm (home-mcron-shepherd-services): Use
'match-record' instead of 'match'.
* gnu/home/services/shells.scm (home-bash-extensions): Likewise.
* gnu/home/services/xdg.scm (serialize-xdg-desktop-entry): Likewise.
---
gnu/home/services/mcron.scm | 58 ++++++++++++++++++------------------
gnu/home/services/shells.scm | 50 +++++++++++++++----------------
gnu/home/services/xdg.scm | 36 +++++++++++-----------
3 files changed, 72 insertions(+), 72 deletions(-)
diff --git a/gnu/home/services/mcron.scm b/gnu/home/services/mcron.scm
index 1d294a997c..5f35bfe054 100644
--- a/gnu/home/services/mcron.scm
+++ b/gnu/home/services/mcron.scm
@@ -77,35 +77,35 @@ (define job-files (@@ (gnu services mcron) job-files))
(define shepherd-schedule-action
(@@ (gnu services mcron) shepherd-schedule-action))
-(define home-mcron-shepherd-services
- (match-lambda
- (($ <home-mcron-configuration> mcron '()) ; no jobs to run
- '())
- (($ <home-mcron-configuration> mcron jobs log? log-format)
- (let ((files (job-files mcron jobs)))
- (list (shepherd-service
- (documentation "User cron jobs.")
- (provision '(mcron))
- (modules `((srfi srfi-1)
- (srfi srfi-26)
- (ice-9 popen) ; for the 'schedule' action
- (ice-9 rdelim)
- (ice-9 match)
- ,@%default-modules))
- (start #~(make-forkexec-constructor
- (list (string-append #$mcron "/bin/mcron")
- #$@(if log?
- #~("--log" "--log-format" #$log-format)
- #~())
- #$@files)
- #:log-file (string-append
- (or (getenv "XDG_LOG_HOME")
- (format #f "~a/.local/var/log"
- (getenv "HOME")))
- "/mcron.log")))
- (stop #~(make-kill-destructor))
- (actions
- (list (shepherd-schedule-action mcron files)))))))))
+(define (home-mcron-shepherd-services config)
+ (match-record config <home-mcron-configuration>
+ (mcron jobs log? log-format)
+ (if (null? jobs)
+ '() ;no jobs to run
+ (let ((files (job-files mcron jobs)))
+ (list (shepherd-service
+ (documentation "User cron jobs.")
+ (provision '(mcron))
+ (modules `((srfi srfi-1)
+ (srfi srfi-26)
+ (ice-9 popen) ;for the 'schedule' action
+ (ice-9 rdelim)
+ (ice-9 match)
+ ,@%default-modules))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$mcron "/bin/mcron")
+ #$@(if log?
+ #~("--log" "--log-format" #$log-format)
+ #~())
+ #$@files)
+ #:log-file (string-append
+ (or (getenv "XDG_LOG_HOME")
+ (format #f "~a/.local/var/log"
+ (getenv "HOME")))
+ "/mcron.log")))
+ (stop #~(make-kill-destructor))
+ (actions
+ (list (shepherd-schedule-action mcron files)))))))))
(define home-mcron-profile (compose list home-mcron-configuration-mcron))
diff --git a/gnu/home/services/shells.scm b/gnu/home/services/shells.scm
index 3e346c3813..b529c8e798 100644
--- a/gnu/home/services/shells.scm
+++ b/gnu/home/services/shells.scm
@@ -25,6 +25,7 @@ (define-module (gnu home services shells)
#:use-module (gnu packages bash)
#:use-module (guix gexp)
#:use-module (guix packages)
+ #:use-module (guix records)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
@@ -479,31 +480,30 @@ (define-configuration/no-serialization home-bash-extension
with text blocks from other extensions and the base service."))
(define (home-bash-extensions original-config extension-configs)
- (match original-config
- (($ <home-bash-configuration> _ _ environment-variables aliases
- bash-profile bashrc bash-logout)
- (home-bash-configuration
- (inherit original-config)
- (environment-variables
- (append environment-variables
- (append-map
- home-bash-extension-environment-variables extension-configs)))
- (aliases
- (append aliases
- (append-map
- home-bash-extension-aliases extension-configs)))
- (bash-profile
- (append bash-profile
- (append-map
- home-bash-extension-bash-profile extension-configs)))
- (bashrc
- (append bashrc
- (append-map
- home-bash-extension-bashrc extension-configs)))
- (bash-logout
- (append bash-logout
- (append-map
- home-bash-extension-bash-logout extension-configs)))))))
+ (match-record original-config <home-bash-configuration>
+ (environment-variables aliases bash-profile bashrc bash-logout)
+ (home-bash-configuration
+ (inherit original-config)
+ (environment-variables
+ (append environment-variables
+ (append-map
+ home-bash-extension-environment-variables extension-configs)))
+ (aliases
+ (append aliases
+ (append-map
+ home-bash-extension-aliases extension-configs)))
+ (bash-profile
+ (append bash-profile
+ (append-map
+ home-bash-extension-bash-profile extension-configs)))
+ (bashrc
+ (append bashrc
+ (append-map
+ home-bash-extension-bashrc extension-configs)))
+ (bash-logout
+ (append bash-logout
+ (append-map
+ home-bash-extension-bash-logout extension-configs))))))
(define home-bash-service-type
(service-type (name 'home-bash)
diff --git a/gnu/home/services/xdg.scm b/gnu/home/services/xdg.scm
index 63c6041cd4..3c6cb773ad 100644
--- a/gnu/home/services/xdg.scm
+++ b/gnu/home/services/xdg.scm
@@ -383,25 +383,25 @@ (define (format-config key val)
(define (serialize-alist config)
(generic-serialize-alist append format-config config))
- (define (serialize-xdg-desktop-action action)
- (match action
- (($ <xdg-desktop-action> action name config)
- `(,(format #f "[Desktop Action ~a]\n"
- (string-capitalize (maybe-object->string action)))
- ,(format #f "Name=~a\n" name)
- ,@(serialize-alist config)))))
+ (define (serialize-xdg-desktop-action desktop-action)
+ (match-record desktop-action <xdg-desktop-action>
+ (action name config)
+ `(,(format #f "[Desktop Action ~a]\n"
+ (string-capitalize (maybe-object->string action)))
+ ,(format #f "Name=~a\n" name)
+ ,@(serialize-alist config))))
- (match entry
- (($ <xdg-desktop-entry> file name type config actions)
- (list (if (string-suffix? file ".desktop")
- file
- (string-append file ".desktop"))
- `("[Desktop Entry]\n"
- ,(format #f "Name=~a\n" name)
- ,(format #f "Type=~a\n"
- (string-capitalize (symbol->string type)))
- ,@(serialize-alist config)
- ,@(append-map serialize-xdg-desktop-action actions))))))
+ (match-record entry <xdg-desktop-entry>
+ (file name type config actions)
+ (list (if (string-suffix? file ".desktop")
+ file
+ (string-append file ".desktop"))
+ `("[Desktop Entry]\n"
+ ,(format #f "Name=~a\n" name)
+ ,(format #f "Type=~a\n"
+ (string-capitalize (symbol->string type)))
+ ,@(serialize-alist config)
+ ,@(append-map serialize-xdg-desktop-action actions)))))
(define-configuration home-xdg-mime-applications-configuration
(added
--
2.38.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [bug#59390] [PATCH 4/5] services: base: Use 'match-record' instead of 'match'.
2022-11-19 22:24 ` [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 2/5] doc: Recommend 'match-record' Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 3/5] home: services: Use 'match-record' instead of 'match' Ludovic Courtès
@ 2022-11-19 22:24 ` Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 5/5] services: networking: Avoid 'match' on records Ludovic Courtès
3 siblings, 0 replies; 7+ messages in thread
From: Ludovic Courtès @ 2022-11-19 22:24 UTC (permalink / raw)
To: 59390; +Cc: Ludovic Courtès
* 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 | 882 +++++++++++++++++++++---------------------
1 file changed, 440 insertions(+), 442 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 @@ (define (default-serial-port)
((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")))))
+(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))
+ ;; 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")
- #~())
+ (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 @@ (define-record-type* <mingetty-configuration>
(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))))
+(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))
+ ;; 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")
+ (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
+ ;; 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)))))))
+ #$@(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 @@ (define %nscd-default-configuration
(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"
+ (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"
- "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")))))
+ "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 config
- (($ <nscd-configuration> log-file debug-level caches)
- (plain-file "nscd.conf"
- (string-append "\
+ (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 @@ (define discover?
(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)
+ (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 build-accounts
- #:group build-group)))))
+ ;; 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 @@ (define kvm-udev-rule
(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))
+ (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))
+ ;; 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"))
+ (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))))))
+ (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")
+ ;; 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* ((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)
+ (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")
+ ;; 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))
+ ;; 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)))))))
+ ;; 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 @@ (define udev.conf
(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 @@ (define udev-service-type
(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 @@ (define-record-type* <gpm-configuration>
(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 @@ (define (network-tear-down/hurd 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))
+(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)
+ #$@(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 @@ (define network-set-up/linux
#: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)
+ #$(network-route-source route))))
+ routes)
+ #$@(map (match-lambda
+ (($ <network-link> name type arguments)
#~(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)
- #~(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 @@ (define-record-type* <greetd-agreety-session>
(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-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
- (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-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>)
--
2.38.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [bug#59390] [PATCH 5/5] services: networking: Avoid 'match' on records.
2022-11-19 22:24 ` [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time Ludovic Courtès
` (2 preceding siblings ...)
2022-11-19 22:24 ` [bug#59390] [PATCH 4/5] services: base: " Ludovic Courtès
@ 2022-11-19 22:24 ` Ludovic Courtès
3 siblings, 0 replies; 7+ messages in thread
From: Ludovic Courtès @ 2022-11-19 22:24 UTC (permalink / raw)
To: 59390; +Cc: Ludovic Courtès
* gnu/services/networking.scm (dhcp-client-shepherd-service): Use
accessors instead of 'match'.
(inetd-shepherd-service): Likewise.
(tor-shepherd-service): Likewise.
(network-manager-service-type): Likewise.
(modem-manager-service-type): Likewise.
(wpa-supplicant-service-type): Likewise.
(openvswitch-activation): Likewise.
(openvswitch-shepherd-service): Likewise.
(dhcpd-shepherd-service): Use 'match-record' instead of 'match'.
(dhcpd-activation): Likewise.
(ntp-server->string): Likewise.
(ntp-shepherd-service): Likewise.
(tor-configuration->torrc): Likewise.
(network-manager-activation): Likewise.
(network-manager-environment): Likewise.
(network-manager-shepherd-service): Likewise.
(usb-modeswitch-configuration->udev-rules): Likewise.
(wpa-supplicant-shepherd-service): Likewise.
(iptables-shepherd-service): Likewise.
(nftables-shepherd-service): Likewise.
(keepalived-shepherd-service): Likewise.
---
gnu/services/networking.scm | 661 ++++++++++++++++++------------------
1 file changed, 327 insertions(+), 334 deletions(-)
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index de02f16a34..4f5af1beb0 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -277,8 +277,10 @@ (define-record-type* <dhcp-client-configuration>
(define dhcp-client-shepherd-service
(match-lambda
- (($ <dhcp-client-configuration> package interfaces)
- (let ((pid-file "/var/run/dhclient.pid"))
+ ((? dhcp-client-configuration? config)
+ (let ((package (dhcp-client-configuration-package config))
+ (interfaces (dhcp-client-configuration-interfaces config))
+ (pid-file "/var/run/dhclient.pid"))
(list (shepherd-service
(documentation "Set up networking via DHCP.")
(requirement '(user-processes udev))
@@ -359,46 +361,46 @@ (define-record-type* <dhcpd-configuration>
(interfaces dhcpd-configuration-interfaces
(default '())))
-(define dhcpd-shepherd-service
- (match-lambda
- (($ <dhcpd-configuration> package config-file version run-directory
- lease-file pid-file interfaces)
- (unless config-file
- (error "Must supply a config-file"))
- (list (shepherd-service
- ;; Allow users to easily run multiple versions simultaneously.
- (provision (list (string->symbol
- (string-append "dhcpv" version "-daemon"))))
- (documentation (string-append "Run the DHCPv" version " daemon"))
- (requirement '(networking))
- (start #~(make-forkexec-constructor
- '(#$(file-append package "/sbin/dhcpd")
- #$(string-append "-" version)
- "-lf" #$lease-file
- "-pf" #$pid-file
- "-cf" #$config-file
- #$@interfaces)
- #:pid-file #$pid-file))
- (stop #~(make-kill-destructor)))))))
+(define (dhcpd-shepherd-service config)
+ (match-record config <dhcpd-configuration>
+ (package config-file version run-directory
+ lease-file pid-file interfaces)
+ (unless config-file
+ (error "Must supply a config-file"))
+ (list (shepherd-service
+ ;; Allow users to easily run multiple versions simultaneously.
+ (provision (list (string->symbol
+ (string-append "dhcpv" version "-daemon"))))
+ (documentation (string-append "Run the DHCPv" version " daemon"))
+ (requirement '(networking))
+ (start #~(make-forkexec-constructor
+ '(#$(file-append package "/sbin/dhcpd")
+ #$(string-append "-" version)
+ "-lf" #$lease-file
+ "-pf" #$pid-file
+ "-cf" #$config-file
+ #$@interfaces)
+ #:pid-file #$pid-file))
+ (stop #~(make-kill-destructor))))))
-(define dhcpd-activation
- (match-lambda
- (($ <dhcpd-configuration> package config-file version run-directory
- lease-file pid-file interfaces)
- (with-imported-modules '((guix build utils))
- #~(begin
- (unless (file-exists? #$run-directory)
- (mkdir #$run-directory))
- ;; According to the DHCP manual (man dhcpd.leases), the lease
- ;; database must be present for dhcpd to start successfully.
- (unless (file-exists? #$lease-file)
- (with-output-to-file #$lease-file
- (lambda _ (display ""))))
- ;; Validate the config.
- (invoke/quiet
- #$(file-append package "/sbin/dhcpd")
- #$(string-append "-" version)
- "-t" "-cf" #$config-file))))))
+(define (dhcpd-activation config)
+ (match-record config <dhcpd-configuration>
+ (package config-file version run-directory
+ lease-file pid-file interfaces)
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (unless (file-exists? #$run-directory)
+ (mkdir #$run-directory))
+ ;; According to the DHCP manual (man dhcpd.leases), the lease
+ ;; database must be present for dhcpd to start successfully.
+ (unless (file-exists? #$lease-file)
+ (with-output-to-file #$lease-file
+ (lambda _ (display ""))))
+ ;; Validate the config.
+ (invoke/quiet
+ #$(file-append package "/sbin/dhcpd")
+ #$(string-append "-" version)
+ "-t" "-cf" #$config-file)))))
(define dhcpd-service-type
(service-type
@@ -449,16 +451,16 @@ (define (flatten lst)
(fold loop res x)
(cons (format #f "~a" x) res)))))
- (match ntp-server
- (($ <ntp-server> type address options)
- ;; XXX: It'd be neater if fields were validated at the syntax level (for
- ;; static ones at least). Perhaps the Guix record type could support a
- ;; predicate property on a field?
- (unless (enum-set-member? type ntp-server-types)
- (error "Invalid NTP server type" type))
- (string-join (cons* (symbol->string type)
- address
- (flatten options))))))
+ (match-record ntp-server <ntp-server>
+ (type address options)
+ ;; XXX: It'd be neater if fields were validated at the syntax level (for
+ ;; static ones at least). Perhaps the Guix record type could support a
+ ;; predicate property on a field?
+ (unless (enum-set-member? type ntp-server-types)
+ (error "Invalid NTP server type" type))
+ (string-join (cons* (symbol->string type)
+ address
+ (flatten options)))))
(define %ntp-servers
;; Default set of NTP servers. These URLs are managed by the NTP Pool project.
@@ -497,17 +499,16 @@ (define (ntp-configuration-servers ntp-configuration)
((($ <ntp-server>) ($ <ntp-server>) ...)
ntp-servers))))
-(define ntp-shepherd-service
- (lambda (config)
- (match config
- (($ <ntp-configuration> ntp servers allow-large-adjustment?)
- (let ((servers (ntp-configuration-servers config)))
- ;; TODO: Add authentication support.
- (define config
- (string-append "driftfile /var/run/ntpd/ntp.drift\n"
- (string-join (map ntp-server->string servers)
- "\n")
- "
+(define (ntp-shepherd-service config)
+ (match-record config <ntp-configuration>
+ (ntp servers allow-large-adjustment?)
+ (let ((servers (ntp-configuration-servers config)))
+ ;; TODO: Add authentication support.
+ (define config
+ (string-append "driftfile /var/run/ntpd/ntp.drift\n"
+ (string-join (map ntp-server->string servers)
+ "\n")
+ "
# Disable status queries as a workaround for CVE-2013-5211:
# <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>.
restrict default kod nomodify notrap nopeer noquery limited
@@ -521,21 +522,21 @@ (define config
# option by default, as documented in the 'ntp.conf' manual.
restrict source notrap nomodify noquery\n"))
- (define ntpd.conf
- (plain-file "ntpd.conf" config))
+ (define ntpd.conf
+ (plain-file "ntpd.conf" config))
- (list (shepherd-service
- (provision '(ntpd))
- (documentation "Run the Network Time Protocol (NTP) daemon.")
- (requirement '(user-processes networking))
- (start #~(make-forkexec-constructor
- (list (string-append #$ntp "/bin/ntpd") "-n"
- "-c" #$ntpd.conf "-u" "ntpd"
- #$@(if allow-large-adjustment?
- '("-g")
- '()))
- #:log-file "/var/log/ntpd.log"))
- (stop #~(make-kill-destructor)))))))))
+ (list (shepherd-service
+ (provision '(ntpd))
+ (documentation "Run the Network Time Protocol (NTP) daemon.")
+ (requirement '(user-processes networking))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$ntp "/bin/ntpd") "-n"
+ "-c" #$ntpd.conf "-u" "ntpd"
+ #$@(if allow-large-adjustment?
+ '("-g")
+ '()))
+ #:log-file "/var/log/ntpd.log"))
+ (stop #~(make-kill-destructor)))))))
(define %ntp-accounts
(list (user-account
@@ -742,19 +743,19 @@ (define (inetd-config-file entries)
" ") "\n")))
entries)))
-(define inetd-shepherd-service
- (match-lambda
- (($ <inetd-configuration> program ()) '()) ; empty list of entries -> do nothing
- (($ <inetd-configuration> program entries)
- (list
- (shepherd-service
- (documentation "Run inetd.")
- (provision '(inetd))
- (requirement '(user-processes networking syslogd))
- (start #~(make-forkexec-constructor
- (list #$program #$(inetd-config-file entries))
- #:pid-file "/var/run/inetd.pid"))
- (stop #~(make-kill-destructor)))))))
+(define (inetd-shepherd-service config)
+ (let ((entries (inetd-configuration-entries config)))
+ (if (null? entries)
+ '() ;do nothing
+ (let ((program (inetd-configuration-program config)))
+ (list (shepherd-service
+ (documentation "Run inetd.")
+ (provision '(inetd))
+ (requirement '(user-processes networking syslogd))
+ (start #~(make-forkexec-constructor
+ (list #$program #$(inetd-config-file entries))
+ #:pid-file "/var/run/inetd.pid"))
+ (stop #~(make-kill-destructor))))))))
(define-public inetd-service-type
(service-type
@@ -938,97 +939,94 @@ (define-record-type <hidden-service>
(define (tor-configuration->torrc config)
"Return a 'torrc' file for CONFIG."
- (match config
- (($ <tor-configuration> tor config-file services
- socks-socket-type control-socket?)
- (computed-file
- "torrc"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (ice-9 match))
+ (match-record config <tor-configuration>
+ (tor config-file hidden-services socks-socket-type control-socket?)
+ (computed-file
+ "torrc"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 match))
- (call-with-output-file #$output
- (lambda (port)
- (display "\
+ (call-with-output-file #$output
+ (lambda (port)
+ (display "\
### These lines were generated from your system configuration:
DataDirectory /var/lib/tor
Log notice syslog\n" port)
- (when (eq? 'unix '#$socks-socket-type)
- (display "\
+ (when (eq? 'unix '#$socks-socket-type)
+ (display "\
SocksPort unix:/var/run/tor/socks-sock
UnixSocksGroupWritable 1\n" port))
- (when #$control-socket?
- (display "\
+ (when #$control-socket?
+ (display "\
ControlSocket unix:/var/run/tor/control-sock GroupWritable RelaxDirModeCheck
ControlSocketsGroupWritable 1\n"
- port))
+ port))
- (for-each (match-lambda
- ((service (ports hosts) ...)
- (format port "\
+ (for-each (match-lambda
+ ((service (ports hosts) ...)
+ (format port "\
HiddenServiceDir /var/lib/tor/hidden-services/~a~%"
- service)
- (for-each (lambda (tcp-port host)
- (format port "\
+ service)
+ (for-each (lambda (tcp-port host)
+ (format port "\
HiddenServicePort ~a ~a~%"
- tcp-port host))
- ports hosts)))
- '#$(map (match-lambda
- (($ <hidden-service> name mapping)
- (cons name mapping)))
- services))
+ tcp-port host))
+ ports hosts)))
+ '#$(map (match-lambda
+ (($ <hidden-service> name mapping)
+ (cons name mapping)))
+ hidden-services))
- (display "\
+ (display "\
### End of automatically generated lines.\n\n" port)
- ;; Append the user's config file.
- (call-with-input-file #$config-file
- (lambda (input)
- (dump-port input port)))
- #t))))))))
+ ;; Append the user's config file.
+ (call-with-input-file #$config-file
+ (lambda (input)
+ (dump-port input port)))
+ #t)))))))
(define (tor-shepherd-service config)
"Return a <shepherd-service> running Tor."
- (match config
- (($ <tor-configuration> tor)
- (let* ((torrc (tor-configuration->torrc config))
- (tor (least-authority-wrapper
- (file-append tor "/bin/tor")
- #:name "tor"
- #:mappings (list (file-system-mapping
- (source "/var/lib/tor")
- (target source)
- (writable? #t))
- (file-system-mapping
- (source "/dev/log") ;for syslog
- (target source))
- (file-system-mapping
- (source "/var/run/tor")
- (target source)
- (writable? #t))
- (file-system-mapping
- (source torrc)
- (target source)))
- #:namespaces (delq 'net %namespaces))))
- (list (shepherd-service
- (provision '(tor))
+ (let* ((torrc (tor-configuration->torrc config))
+ (tor (least-authority-wrapper
+ (file-append (tor-configuration-tor config) "/bin/tor")
+ #:name "tor"
+ #:mappings (list (file-system-mapping
+ (source "/var/lib/tor")
+ (target source)
+ (writable? #t))
+ (file-system-mapping
+ (source "/dev/log") ;for syslog
+ (target source))
+ (file-system-mapping
+ (source "/var/run/tor")
+ (target source)
+ (writable? #t))
+ (file-system-mapping
+ (source torrc)
+ (target source)))
+ #:namespaces (delq 'net %namespaces))))
+ (list (shepherd-service
+ (provision '(tor))
- ;; Tor needs at least one network interface to be up, hence the
- ;; dependency on 'loopback'.
- (requirement '(user-processes loopback syslogd))
+ ;; Tor needs at least one network interface to be up, hence the
+ ;; dependency on 'loopback'.
+ (requirement '(user-processes loopback syslogd))
- ;; XXX: #:pid-file won't work because the wrapped 'tor'
- ;; program would print its PID within the user namespace
- ;; instead of its actual PID outside. There's no inetd or
- ;; systemd socket activation support either (there's
- ;; 'sd_notify' though), so we're stuck with that.
- (start #~(make-forkexec-constructor
- (list #$tor "-f" #$torrc)
- #:user "tor" #:group "tor"))
- (stop #~(make-kill-destructor))
- (actions (list (shepherd-configuration-action torrc)))
- (documentation "Run the Tor anonymous network overlay.")))))))
+ ;; XXX: #:pid-file won't work because the wrapped 'tor'
+ ;; program would print its PID within the user namespace
+ ;; instead of its actual PID outside. There's no inetd or
+ ;; systemd socket activation support either (there's
+ ;; 'sd_notify' though), so we're stuck with that.
+ (start #~(make-forkexec-constructor
+ (list #$tor "-f" #$torrc)
+ #:user "tor" #:group "tor"))
+ (stop #~(make-kill-destructor))
+ (actions (list (shepherd-configuration-action torrc)))
+ (documentation "Run the Tor anonymous network overlay.")))))
(define (tor-activation config)
"Set up directories for Tor and its hidden services, if any."
@@ -1145,17 +1143,17 @@ (define-record-type* <network-manager-configuration>
(vpn-plugins network-manager-configuration-vpn-plugins ;list of file-like
(default '())))
-(define network-manager-activation
+(define (network-manager-activation config)
;; Activation gexp for NetworkManager
- (match-lambda
- (($ <network-manager-configuration> network-manager dns vpn-plugins)
- #~(begin
- (use-modules (guix build utils))
- (mkdir-p "/etc/NetworkManager/system-connections")
- #$@(if (equal? dns "dnsmasq")
- ;; create directory to store dnsmasq lease file
- '((mkdir-p "/var/lib/misc"))
- '())))))
+ (match-record config <network-manager-configuration>
+ (network-manager dns vpn-plugins)
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p "/etc/NetworkManager/system-connections")
+ #$@(if (equal? dns "dnsmasq")
+ ;; create directory to store dnsmasq lease file
+ '((mkdir-p "/var/lib/misc"))
+ '()))))
(define (vpn-plugin-directory plugins)
"Return a directory containing PLUGINS, the NM VPN plugins."
@@ -1188,44 +1186,44 @@ (define accounts
(cons (user-group (name "network-manager") (system? #t))
accounts))))
-(define network-manager-environment
- (match-lambda
- (($ <network-manager-configuration> network-manager dns vpn-plugins)
- ;; Define this variable in the global environment such that
- ;; "nmcli connection import type openvpn file foo.ovpn" works.
- `(("NM_VPN_PLUGIN_DIR"
- . ,(file-append (vpn-plugin-directory vpn-plugins)
- "/lib/NetworkManager/VPN"))))))
+(define (network-manager-environment config)
+ (match-record config <network-manager-configuration>
+ (network-manager dns vpn-plugins)
+ ;; Define this variable in the global environment such that
+ ;; "nmcli connection import type openvpn file foo.ovpn" works.
+ `(("NM_VPN_PLUGIN_DIR"
+ . ,(file-append (vpn-plugin-directory vpn-plugins)
+ "/lib/NetworkManager/VPN")))))
-(define network-manager-shepherd-service
- (match-lambda
- (($ <network-manager-configuration> network-manager dns vpn-plugins)
- (let ((conf (plain-file "NetworkManager.conf"
- (string-append "[main]\ndns=" dns "\n")))
- (vpn (vpn-plugin-directory vpn-plugins)))
- (list (shepherd-service
- (documentation "Run the NetworkManager.")
- (provision '(networking))
- (requirement '(user-processes dbus-system wpa-supplicant loopback))
- (start #~(make-forkexec-constructor
- (list (string-append #$network-manager
- "/sbin/NetworkManager")
- (string-append "--config=" #$conf)
- "--no-daemon")
- #:environment-variables
- (list (string-append "NM_VPN_PLUGIN_DIR=" #$vpn
- "/lib/NetworkManager/VPN")
- ;; Override non-existent default users
- "NM_OPENVPN_USER="
- "NM_OPENVPN_GROUP=")))
- (stop #~(make-kill-destructor))))))))
+(define (network-manager-shepherd-service config)
+ (match-record config <network-manager-configuration>
+ (network-manager dns vpn-plugins)
+ (let ((conf (plain-file "NetworkManager.conf"
+ (string-append "[main]\ndns=" dns "\n")))
+ (vpn (vpn-plugin-directory vpn-plugins)))
+ (list (shepherd-service
+ (documentation "Run the NetworkManager.")
+ (provision '(networking))
+ (requirement '(user-processes dbus-system wpa-supplicant loopback))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$network-manager
+ "/sbin/NetworkManager")
+ (string-append "--config=" #$conf)
+ "--no-daemon")
+ #:environment-variables
+ (list (string-append "NM_VPN_PLUGIN_DIR=" #$vpn
+ "/lib/NetworkManager/VPN")
+ ;; Override non-existent default users
+ "NM_OPENVPN_USER="
+ "NM_OPENVPN_GROUP=")))
+ (stop #~(make-kill-destructor)))))))
(define network-manager-service-type
- (let
- ((config->packages
- (match-lambda
- (($ <network-manager-configuration> network-manager _ vpn-plugins)
- `(,network-manager ,@vpn-plugins)))))
+ (let ((config->packages
+ (lambda (config)
+ (match-record config <network-manager-configuration>
+ (network-manager vpn-plugins)
+ `(,network-manager ,@vpn-plugins)))))
(service-type
(name 'network-manager)
@@ -1332,9 +1330,8 @@ (define connman-service-type
(define modem-manager-service-type
(let ((config->package
- (match-lambda
- (($ <modem-manager-configuration> modem-manager)
- (list modem-manager)))))
+ (lambda (config)
+ (list (modem-manager-configuration-modem-manager config)))))
(service-type (name 'modem-manager)
(extensions
(list (service-extension dbus-root-service-type
@@ -1405,24 +1402,25 @@ (define (usb-modeswitch-configuration->udev-rules config)
usb-modeswitch package specified in CONFIG. The rules file will invoke
usb_modeswitch.sh from the usb-modeswitch package, modified to pass the right
config file."
- (match config
- (($ <usb-modeswitch-configuration> usb-modeswitch data config-file)
- (computed-file
- "usb_modeswitch.rules"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- (let ((in (string-append #$data "/udev/40-usb_modeswitch.rules"))
- (out (string-append #$output "/lib/udev/rules.d"))
- (script #$(usb-modeswitch-sh usb-modeswitch config-file)))
- (mkdir-p out)
- (chdir out)
- (install-file in out)
- (substitute* "40-usb_modeswitch.rules"
- (("PROGRAM=\"usb_modeswitch")
- (string-append "PROGRAM=\"" script "/usb_modeswitch"))
- (("RUN\\+=\"usb_modeswitch")
- (string-append "RUN+=\"" script "/usb_modeswitch"))))))))))
+ (match-record config <usb-modeswitch-configuration>
+ (usb-modeswitch usb-modeswitch-data config-file)
+ (computed-file
+ "usb_modeswitch.rules"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (let ((in (string-append #$usb-modeswitch-data
+ "/udev/40-usb_modeswitch.rules"))
+ (out (string-append #$output "/lib/udev/rules.d"))
+ (script #$(usb-modeswitch-sh usb-modeswitch config-file)))
+ (mkdir-p out)
+ (chdir out)
+ (install-file in out)
+ (substitute* "40-usb_modeswitch.rules"
+ (("PROGRAM=\"usb_modeswitch")
+ (string-append "PROGRAM=\"" script "/usb_modeswitch"))
+ (("RUN\\+=\"usb_modeswitch")
+ (string-append "RUN+=\"" script "/usb_modeswitch")))))))))
(define usb-modeswitch-service-type
(service-type
@@ -1466,40 +1464,39 @@ (define-record-type* <wpa-supplicant-configuration>
(extra-options wpa-supplicant-configuration-extra-options ;list of strings
(default '())))
-(define wpa-supplicant-shepherd-service
- (match-lambda
- (($ <wpa-supplicant-configuration> wpa-supplicant requirement pid-file dbus?
- interface config-file extra-options)
- (list (shepherd-service
- (documentation "Run the WPA supplicant daemon")
- (provision '(wpa-supplicant))
- (requirement (if dbus?
- (cons 'dbus-system requirement)
- requirement))
- (start #~(make-forkexec-constructor
- (list (string-append #$wpa-supplicant
- "/sbin/wpa_supplicant")
- (string-append "-P" #$pid-file)
- "-B" ;run in background
- "-s" ;log to syslogd
- #$@(if dbus?
- #~("-u")
- #~())
- #$@(if interface
- #~((string-append "-i" #$interface))
- #~())
- #$@(if config-file
- #~((string-append "-c" #$config-file))
- #~())
- #$@extra-options)
- #:pid-file #$pid-file))
- (stop #~(make-kill-destructor)))))))
+(define (wpa-supplicant-shepherd-service config)
+ (match-record config <wpa-supplicant-configuration>
+ (wpa-supplicant requirement pid-file dbus?
+ interface config-file extra-options)
+ (list (shepherd-service
+ (documentation "Run the WPA supplicant daemon")
+ (provision '(wpa-supplicant))
+ (requirement (if dbus?
+ (cons 'dbus-system requirement)
+ requirement))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$wpa-supplicant
+ "/sbin/wpa_supplicant")
+ (string-append "-P" #$pid-file)
+ "-B" ;run in background
+ "-s" ;log to syslogd
+ #$@(if dbus?
+ #~("-u")
+ #~())
+ #$@(if interface
+ #~((string-append "-i" #$interface))
+ #~())
+ #$@(if config-file
+ #~((string-append "-c" #$config-file))
+ #~())
+ #$@extra-options)
+ #:pid-file #$pid-file))
+ (stop #~(make-kill-destructor))))))
(define wpa-supplicant-service-type
(let ((config->package
- (match-lambda
- (($ <wpa-supplicant-configuration> wpa-supplicant)
- (list wpa-supplicant)))))
+ (lambda (config)
+ (list (wpa-supplicant-configuration-wpa-supplicant config)))))
(service-type (name 'wpa-supplicant)
(extensions
(list (service-extension shepherd-root-service-type
@@ -1621,41 +1618,38 @@ (define-record-type* <openvswitch-configuration>
(package openvswitch-configuration-package
(default openvswitch)))
-(define openvswitch-activation
- (match-lambda
- (($ <openvswitch-configuration> package)
- (let ((ovsdb-tool (file-append package "/bin/ovsdb-tool")))
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- (mkdir-p "/var/run/openvswitch")
- (mkdir-p "/var/lib/openvswitch")
- (let ((conf.db "/var/lib/openvswitch/conf.db"))
- (unless (file-exists? conf.db)
- (system* #$ovsdb-tool "create" conf.db)))))))))
+(define (openvswitch-activation config)
+ (let ((ovsdb-tool (file-append (openvswitch-configuration-package config)
+ "/bin/ovsdb-tool")))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p "/var/run/openvswitch")
+ (mkdir-p "/var/lib/openvswitch")
+ (let ((conf.db "/var/lib/openvswitch/conf.db"))
+ (unless (file-exists? conf.db)
+ (system* #$ovsdb-tool "create" conf.db)))))))
-(define openvswitch-shepherd-service
- (match-lambda
- (($ <openvswitch-configuration> package)
- (let ((ovsdb-server (file-append package "/sbin/ovsdb-server"))
- (ovs-vswitchd (file-append package "/sbin/ovs-vswitchd")))
- (list
- (shepherd-service
- (provision '(ovsdb))
- (documentation "Run the Open vSwitch database server.")
- (start #~(make-forkexec-constructor
- (list #$ovsdb-server "--pidfile"
- "--remote=punix:/var/run/openvswitch/db.sock")
- #:pid-file "/var/run/openvswitch/ovsdb-server.pid"))
- (stop #~(make-kill-destructor)))
- (shepherd-service
- (provision '(vswitchd))
- (requirement '(ovsdb))
- (documentation "Run the Open vSwitch daemon.")
- (start #~(make-forkexec-constructor
- (list #$ovs-vswitchd "--pidfile")
- #:pid-file "/var/run/openvswitch/ovs-vswitchd.pid"))
- (stop #~(make-kill-destructor))))))))
+(define (openvswitch-shepherd-service config)
+ (let* ((package (openvswitch-configuration-package config))
+ (ovsdb-server (file-append package "/sbin/ovsdb-server"))
+ (ovs-vswitchd (file-append package "/sbin/ovs-vswitchd")))
+ (list (shepherd-service
+ (provision '(ovsdb))
+ (documentation "Run the Open vSwitch database server.")
+ (start #~(make-forkexec-constructor
+ (list #$ovsdb-server "--pidfile"
+ "--remote=punix:/var/run/openvswitch/db.sock")
+ #:pid-file "/var/run/openvswitch/ovsdb-server.pid"))
+ (stop #~(make-kill-destructor)))
+ (shepherd-service
+ (provision '(vswitchd))
+ (requirement '(ovsdb))
+ (documentation "Run the Open vSwitch daemon.")
+ (start #~(make-forkexec-constructor
+ (list #$ovs-vswitchd "--pidfile")
+ #:pid-file "/var/run/openvswitch/ovs-vswitchd.pid"))
+ (stop #~(make-kill-destructor))))))
(define openvswitch-service-type
(service-type
@@ -1695,20 +1689,20 @@ (define-record-type* <iptables-configuration>
(ipv6-rules iptables-configuration-ipv6-rules
(default %iptables-accept-all-rules)))
-(define iptables-shepherd-service
- (match-lambda
- (($ <iptables-configuration> iptables ipv4-rules ipv6-rules)
- (let ((iptables-restore (file-append iptables "/sbin/iptables-restore"))
- (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore")))
- (shepherd-service
- (documentation "Packet filtering framework")
- (provision '(iptables))
- (start #~(lambda _
- (invoke #$iptables-restore #$ipv4-rules)
- (invoke #$ip6tables-restore #$ipv6-rules)))
- (stop #~(lambda _
- (invoke #$iptables-restore #$%iptables-accept-all-rules)
- (invoke #$ip6tables-restore #$%iptables-accept-all-rules))))))))
+(define (iptables-shepherd-service config)
+ (match-record config <iptables-configuration>
+ (iptables ipv4-rules ipv6-rules)
+ (let ((iptables-restore (file-append iptables "/sbin/iptables-restore"))
+ (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore")))
+ (shepherd-service
+ (documentation "Packet filtering framework")
+ (provision '(iptables))
+ (start #~(lambda _
+ (invoke #$iptables-restore #$ipv4-rules)
+ (invoke #$ip6tables-restore #$ipv6-rules)))
+ (stop #~(lambda _
+ (invoke #$iptables-restore #$%iptables-accept-all-rules)
+ (invoke #$ip6tables-restore #$%iptables-accept-all-rules)))))))
(define iptables-service-type
(service-type
@@ -1767,17 +1761,17 @@ (define-record-type* <nftables-configuration>
(ruleset nftables-configuration-ruleset ; file-like object
(default %default-nftables-ruleset)))
-(define nftables-shepherd-service
- (match-lambda
- (($ <nftables-configuration> package ruleset)
- (let ((nft (file-append package "/sbin/nft")))
- (shepherd-service
- (documentation "Packet filtering and classification")
- (provision '(nftables))
- (start #~(lambda _
- (invoke #$nft "--file" #$ruleset)))
- (stop #~(lambda _
- (invoke #$nft "flush" "ruleset"))))))))
+(define (nftables-shepherd-service config)
+ (match-record config <nftables-configuration>
+ (package ruleset)
+ (let ((nft (file-append package "/sbin/nft")))
+ (shepherd-service
+ (documentation "Packet filtering and classification")
+ (provision '(nftables))
+ (start #~(lambda _
+ (invoke #$nft "--file" #$ruleset)))
+ (stop #~(lambda _
+ (invoke #$nft "flush" "ruleset")))))))
(define nftables-service-type
(service-type
@@ -2150,23 +2144,22 @@ (define-record-type* <keepalived-configuration>
(config-file keepalived-configuration-config-file ;file-like
(default #f)))
-(define keepalived-shepherd-service
- (match-lambda
- (($ <keepalived-configuration> keepalived config-file)
- (list
- (shepherd-service
- (provision '(keepalived))
- (documentation "Run keepalived.")
- (requirement '(loopback))
- (start #~(make-forkexec-constructor
- (list (string-append #$keepalived "/sbin/keepalived")
- "--dont-fork" "--log-console" "--log-detail"
- "--pid=/var/run/keepalived.pid"
- (string-append "--use-file=" #$config-file))
- #:pid-file "/var/run/keepalived.pid"
- #:log-file "/var/log/keepalived.log"))
- (respawn? #f)
- (stop #~(make-kill-destructor)))))))
+(define (keepalived-shepherd-service config)
+ (match-record config <keepalived-configuration>
+ (keepalived config-file)
+ (list (shepherd-service
+ (provision '(keepalived))
+ (documentation "Run keepalived.")
+ (requirement '(loopback))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$keepalived "/sbin/keepalived")
+ "--dont-fork" "--log-console" "--log-detail"
+ "--pid=/var/run/keepalived.pid"
+ (string-append "--use-file=" #$config-file))
+ #:pid-file "/var/run/keepalived.pid"
+ #:log-file "/var/log/keepalived.log"))
+ (respawn? #f)
+ (stop #~(make-kill-destructor))))))
(define %keepalived-log-rotation
(list (log-rotation
--
2.38.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* bug#59390: [PATCH 0/5] Doing 'match-record' work at expansion time
2022-11-19 22:23 [bug#59390] [PATCH 0/5] Doing 'match-record' work at expansion time Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time Ludovic Courtès
@ 2022-12-01 23:07 ` Ludovic Courtès
1 sibling, 0 replies; 7+ messages in thread
From: Ludovic Courtès @ 2022-12-01 23:07 UTC (permalink / raw)
To: 59390-done
Ludovic Courtès <ludo@gnu.org> skribis:
> This addresses a longstanding issue: making ‘match-record’ efficient,
> and allowing it to error out on unknown field names at macro-expansion
> time.
I went ahead, rebased, and pushed these:
00ddf185e6 services: networking: Avoid 'match' on records.
adfe1064c8 services: base: Use 'match-record' instead of 'match'.
4c8eea027a home: services: Use 'match-record' instead of 'match'.
cc9ee514e3 doc: Recommend 'match-record'.
7c1161dba4 records: 'match-record' checks fields at macro-expansion time.
This change breaks the ABI: we’ll have to run:
make clean-go && make
Inquiries welcome!
Ludo’.
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2022-12-01 23:09 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-11-19 22:23 [bug#59390] [PATCH 0/5] Doing 'match-record' work at expansion time Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 2/5] doc: Recommend 'match-record' Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 3/5] home: services: Use 'match-record' instead of 'match' Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 4/5] services: base: " Ludovic Courtès
2022-11-19 22:24 ` [bug#59390] [PATCH 5/5] services: networking: Avoid 'match' on records Ludovic Courtès
2022-12-01 23:07 ` bug#59390: [PATCH 0/5] Doing 'match-record' work at expansion time Ludovic Courtès
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).