[PATCH 0/5] Doing 'match-record' work at expansion time

  • Done
  • quality assurance status badge
Details
One participant
  • Ludovic Courtès
Owner
unassigned
Submitted by
Ludovic Courtès
Severity
normal
L
L
Ludovic Courtès wrote on 19 Nov 2022 23:23
(address . guix-patches@gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20221119222326.10644-1-ludo@gnu.org
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:

Toggle snippet (22 lines)
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)) ())

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
L
L
Ludovic Courtès wrote on 19 Nov 2022 23:24
[PATCH 1/5] records: 'match-record' checks fields at macro-expansion time.
(address . 59390@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20221119222454.10759-1-ludo@gnu.org
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(-)

Toggle diff (237 lines)
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))))))))
+
+;;;
+;;; 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
L
L
Ludovic Courtès wrote on 19 Nov 2022 23:24
[PATCH 2/5] doc: Recommend 'match-record'.
(address . 59390@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20221119222454.10759-2-ludo@gnu.org
* doc/contributing.texi (Data Types and Pattern Matching): Recommend
'match-record'.
---
doc/contributing.texi | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)

Toggle diff (24 lines)
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
L
L
Ludovic Courtès wrote on 19 Nov 2022 23:24
[PATCH 3/5] home: services: Use 'match-record' instead of 'match'.
(address . 59390@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20221119222454.10759-3-ludo@gnu.org
* 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(-)

Toggle diff (187 lines)
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
L
L
Ludovic Courtès wrote on 19 Nov 2022 23:24
[PATCH 4/5] services: base: Use 'match-record' instead of 'match'.
(address . 59390@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20221119222454.10759-4-ludo@gnu.org
* 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(-)

Toggle diff (390 lines)
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 chec
This message was truncated. Download the full message here.
L
L
Ludovic Courtès wrote on 19 Nov 2022 23:24
[PATCH 5/5] services: networking: Avoid 'match' on records.
(address . 59390@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20221119222454.10759-5-ludo@gnu.org
* 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(-)

Toggle diff (416 lines)
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 "dnsm
This message was truncated. Download the full message here.
L
L
Ludovic Courtès wrote on 2 Dec 2022 00:07
Re: bug#59390: [PATCH 0/5] Doing 'match-record' work at expansion time
(address . 59390-done@debbugs.gnu.org)
87wn7awwn5.fsf@gnu.org
Ludovic Courtès <ludo@gnu.org> skribis:

Toggle quote (4 lines)
> 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’.
Closed
?