Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Sat, 19 Nov 2022 22:24:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 59390 in the body.
You can then email your comments to 59390 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#59390; Package guix-patches.
(Sat, 19 Nov 2022 22:24:02 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>:guix-patches <at> gnu.org.
(Sat, 19 Nov 2022 22:24:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: guix-patches <at> gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 0/5] Doing 'match-record' work at expansion time Date: Sat, 19 Nov 2022 23:23:26 +0100
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
guix-patches <at> gnu.org:bug#59390; Package guix-patches.
(Sat, 19 Nov 2022 22:26:01 GMT) Full text and rfc822 format available.Message #8 received at 59390 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 59390 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time. Date: Sat, 19 Nov 2022 23:24:50 +0100
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 <at> gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw <at> 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
guix-patches <at> gnu.org:bug#59390; Package guix-patches.
(Sat, 19 Nov 2022 22:26:01 GMT) Full text and rfc822 format available.Message #11 received at 59390 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 59390 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 2/5] doc: Recommend 'match-record'. Date: Sat, 19 Nov 2022 23:24:51 +0100
* 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
guix-patches <at> gnu.org:bug#59390; Package guix-patches.
(Sat, 19 Nov 2022 22:26:02 GMT) Full text and rfc822 format available.Message #14 received at 59390 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 59390 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 3/5] home: services: Use 'match-record' instead of 'match'. Date: Sat, 19 Nov 2022 23:24:52 +0100
* 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
guix-patches <at> gnu.org:bug#59390; Package guix-patches.
(Sat, 19 Nov 2022 22:26:02 GMT) Full text and rfc822 format available.Message #17 received at 59390 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 59390 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 4/5] services: base: Use 'match-record' instead of 'match'. Date: Sat, 19 Nov 2022 23:24:53 +0100
* 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
guix-patches <at> gnu.org:bug#59390; Package guix-patches.
(Sat, 19 Nov 2022 22:26:03 GMT) Full text and rfc822 format available.Message #20 received at 59390 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 59390 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 5/5] services: networking: Avoid 'match' on records. Date: Sat, 19 Nov 2022 23:24:54 +0100
* 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
Ludovic Courtès <ludo <at> gnu.org>:Ludovic Courtès <ludo <at> gnu.org>:Message #25 received at 59390-done <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 59390-done <at> debbugs.gnu.org Subject: Re: bug#59390: [PATCH 0/5] Doing 'match-record' work at expansion time Date: Fri, 02 Dec 2022 00:07:42 +0100
Ludovic Courtès <ludo <at> 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’.
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Fri, 30 Dec 2022 12:24:10 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.