From: Bruno Victal <mirai@makinata.eu>
To: 62298@debbugs.gnu.org
Cc: ludo@gnu.org, Bruno Victal <mirai@makinata.eu>,
liliana.prikler@gmail.com, maxim.cournoyer@gmail.com
Subject: [bug#62298] [PATCH v2 1/8] services: configuration: Add user-defined sanitizer support.
Date: Thu, 23 Mar 2023 15:02:11 +0000 [thread overview]
Message-ID: <e251c56b622dd0324bb4fd38cf65d0a04c8f12fa.1679583701.git.mirai@makinata.eu> (raw)
In-Reply-To: <cover.1679329773.git.mirai@makinata.eu>
This changes the 'custom-serializer' field into a generic
'extra-args' field that can be extended to support new literals.
With this mechanism, the literals 'sanitizer' allow for user-defined
sanitizer procedures while the 'serializer' literal is used for
custom serializer procedures.
The 'empty-serializer' was also added as a 'literal' and can be used
just like it was previously.
With the repurposing of 'custom-serializer' into 'extra-args', to prevent
intolerable confusion, the custom serializer procedures should be
specified using the new 'literals' approach, with the previous “style”
being considered deprecated.
* gnu/services/configuration.scm (define-configuration-helper):
Rename 'custom-serializer' to 'extra-args'.
Add support for literals 'sanitizer', 'serializer' and 'empty-serializer'.
Rename procedure 'field-sanitizer' to 'default-field-sanitizer' to avoid syntax clash.
Only define default field sanitizers if user-defined ones are absent.
(normalize-extra-args): New procedure.
(<configuration-field>)[sanitizer]: New field.
* doc/guix.texi (Complex Configurations): Document the newly added literals.
* tests/services/configuration.scm: Add tests for the new literals.
---
doc/guix.texi | 30 ++++-
gnu/services/configuration.scm | 91 +++++++++++----
tests/services/configuration.scm | 185 ++++++++++++++++++++++++++++++-
3 files changed, 280 insertions(+), 26 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index dfdb26103a..1609e508ef 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -41216,7 +41216,7 @@ Complex Configurations
(@var{field-name}
(@var{type} @var{default-value})
@var{documentation}
- @var{serializer})
+ (serializer @var{serializer}))
(@var{field-name}
(@var{type})
@@ -41225,7 +41225,18 @@ Complex Configurations
(@var{field-name}
(@var{type})
@var{documentation}
- @var{serializer})
+ (serializer @var{serializer}))
+
+(@var{field-name}
+ (@var{type})
+ @var{documentation}
+ (sanitizer @var{sanitizer})
+
+(@var{field-name}
+ (@var{type})
+ @var{documentation}
+ (sanitizer @var{sanitizer})
+ (serializer @var{serializer}))
@end example
@var{field-name} is an identifier that denotes the name of the field in
@@ -41248,6 +41259,21 @@ Complex Configurations
@var{documentation} is a string formatted with Texinfo syntax which
should provide a description of what setting this field does.
+@var{sanitizer} is the name of a procedure which takes one argument,
+a user-supplied value, and returns a ``sanitized'' value for the field.
+If none is specified, the predicate @code{@var{type}?} is automatically
+used to construct an internal sanitizer that asserts the type correctness
+of the field value.
+
+An example of a sanitizer for a field that accepts both strings and
+symbols looks like this:
+@lisp
+(define (sanitize-foo value)
+ (cond ((string? value) value)
+ ((symbol? value) (symbol->string value))
+ (else (throw 'bad! value))))
+@end lisp
+
@var{serializer} is the name of a procedure which takes two arguments,
the first is the name of the field, and the second is the value
corresponding to the field. The procedure should return a string or
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 174c2f20d2..409d4cef00 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -6,6 +6,7 @@
;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,7 +29,8 @@ (define-module (gnu services configuration)
#:use-module (guix gexp)
#:use-module ((guix utils) #:select (source-properties->location))
#:use-module ((guix diagnostics)
- #:select (formatted-message location-file &error-location))
+ #:select (formatted-message location-file &error-location
+ warning))
#:use-module ((guix modules) #:select (file-name->module-name))
#:use-module (guix i18n)
#:autoload (texinfo) (texi-fragment->stexi)
@@ -37,6 +39,7 @@ (define-module (gnu services configuration)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (configuration-field
@@ -44,6 +47,7 @@ (define-module (gnu services configuration)
configuration-field-type
configuration-missing-field
configuration-field-error
+ configuration-field-sanitizer
configuration-field-serializer
configuration-field-getter
configuration-field-default-value-thunk
@@ -116,6 +120,7 @@ (define-record-type* <configuration-field>
(type configuration-field-type)
(getter configuration-field-getter)
(predicate configuration-field-predicate)
+ (sanitizer configuration-field-sanitizer)
(serializer configuration-field-serializer)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
@@ -181,11 +186,45 @@ (define (normalize-field-type+def s)
(values #'(field-type %unset-value)))))
(define (define-configuration-helper serialize? serializer-prefix syn)
+
+ (define (normalize-extra-args s)
+ (let loop ((s s)
+ (sanitizer* %unset-value)
+ (serializer* %unset-value))
+ (syntax-case s (sanitizer serializer empty-serializer)
+ (((sanitizer proc) tail ...)
+ (if (maybe-value-set? sanitizer*)
+ (syntax-violation 'sanitizer "duplicate entry"
+ #'proc)
+ (loop #'(tail ...) #'proc serializer*)))
+ (((serializer proc) tail ...)
+ (if (maybe-value-set? serializer*)
+ (syntax-violation 'serializer "duplicate or conflicting entry"
+ #'proc)
+ (loop #'(tail ...) sanitizer* #'proc)))
+ ((empty-serializer tail ...)
+ (if (maybe-value-set? serializer*)
+ (syntax-violation 'empty-serializer
+ "duplicate or conflicting entry" #f)
+ (loop #'(tail ...) sanitizer* #'empty-serializer)))
+ (() ; stop condition
+ (values (list sanitizer* serializer*)))
+ ((proc) ; TODO: deprecated, to be removed
+ (every (cut eq? <> #f)
+ (map maybe-value-set?
+ (list sanitizer* serializer*)))
+ (begin
+ (warning #f (G_ "specifying serializers after documentation is \
+deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
+ (values (list %unset-value #'proc)))))))
+
(syntax-case syn ()
- ((_ stem (field field-type+def doc custom-serializer ...) ...)
+ ((_ stem (field field-type+def doc extra-args ...) ...)
(with-syntax
((((field-type def) ...)
- (map normalize-field-type+def #'(field-type+def ...))))
+ (map normalize-field-type+def #'(field-type+def ...)))
+ (((sanitizer* serializer*) ...)
+ (map normalize-extra-args #'((extra-args ...) ...))))
(with-syntax
(((field-getter ...)
(map (lambda (field)
@@ -200,21 +239,18 @@ (define (define-configuration-helper serialize? serializer-prefix syn)
((field-type default-value)
default-value))
#'((field-type def) ...)))
+ ((field-sanitizer ...)
+ (map maybe-value #'(sanitizer* ...)))
((field-serializer ...)
- (map (lambda (type custom-serializer)
+ (map (lambda (type proc)
(and serialize?
- (match custom-serializer
- ((serializer)
- serializer)
- (()
- (if serializer-prefix
- (id #'stem
- serializer-prefix
- #'serialize- type)
- (id #'stem #'serialize- type))))))
+ (or (maybe-value proc)
+ (if serializer-prefix
+ (id #'stem serializer-prefix #'serialize- type)
+ (id #'stem #'serialize- type)))))
#'(field-type ...)
- #'((custom-serializer ...) ...))))
- (define (field-sanitizer name pred)
+ #'(serializer* ...))))
+ (define (default-field-sanitizer name pred)
;; Define a macro for use as a record field sanitizer, where NAME
;; is the name of the field and PRED is the predicate that tells
;; whether a value is valid for this field.
@@ -235,21 +271,29 @@ (define (define-configuration-helper serialize? serializer-prefix syn)
#`(begin
;; Define field validation macros.
- #,@(map field-sanitizer
- #'(field ...)
- #'(field-predicate ...))
+ #,@(filter-map (lambda (name pred sanitizer)
+ (if sanitizer
+ #f
+ (default-field-sanitizer name pred)))
+ #'(field ...)
+ #'(field-predicate ...)
+ #'(field-sanitizer ...))
(define-record-type* #,(id #'stem #'< #'stem #'>)
stem
#,(id #'stem #'make- #'stem)
#,(id #'stem #'stem #'?)
- #,@(map (lambda (name getter def)
- #`(#,name #,getter (default #,def)
+ #,@(map (lambda (name getter def sanitizer)
+ #`(#,name #,getter
+ (default #,def)
(sanitize
- #,(id #'stem #'validate- #'stem #'- name))))
+ #,(or sanitizer
+ (id #'stem
+ #'validate- #'stem #'- name)))))
#'(field ...)
#'(field-getter ...)
- #'(field-default ...))
+ #'(field-default ...)
+ #'(field-sanitizer ...))
(%location #,(id #'stem #'stem #'-source-location)
(default (and=> (current-source-location)
source-properties->location))
@@ -261,6 +305,9 @@ (define (define-configuration-helper serialize? serializer-prefix syn)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
+ (sanitizer
+ (or field-sanitizer
+ (id #'stem #'validate- #'stem #'- #'field)))
(serializer field-serializer)
(default-value-thunk
(lambda ()
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 4f8a74dc8a..64b7bb1543 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +23,7 @@ (define-module (tests services configuration)
#:use-module (gnu services configuration)
#:use-module (guix diagnostics)
#:use-module (guix gexp)
+ #:autoload (guix i18n) (G_)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64))
@@ -46,14 +48,14 @@ (define-configuration port-configuration
(port-configuration-port (port-configuration)))
(test-equal "wrong type for a field"
- '("configuration.scm" 57 11) ;error location
+ '("configuration.scm" 59 11) ;error location
(guard (c ((configuration-error? c)
(let ((loc (error-location c)))
(list (basename (location-file loc))
(location-line loc)
(location-column loc)))))
(port-configuration
- ;; This is line 56; the test relies on line/column numbers!
+ ;; This is line 58; the test relies on line/column numbers!
(port "This is not a number!"))))
(define-configuration port-configuration-cs
@@ -109,6 +111,185 @@ (define-configuration configuration-with-prefix
(let ((config (configuration-with-prefix)))
(serialize-configuration config configuration-with-prefix-fields))))
+\f
+;;;
+;;; define-configuration macro, extra-args literals
+;;;
+
+(define (eval-gexp x)
+ "Get serialized config as string."
+ (eval (gexp->approximate-sexp x)
+ (current-module)))
+
+(define (port? value)
+ (or (string? value) (number? value)))
+
+(define (sanitize-port value)
+ (cond ((number? value) value)
+ ((string? value) (string->number value))
+ (else (raise (formatted-message (G_ "Bad value: ~a") value)))))
+
+(test-group "Basic sanitizer literal tests"
+ (define serialize-port serialize-number)
+
+ (define-configuration config-with-sanitizer
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ (sanitizer sanitize-port)))
+
+ (test-equal "default value, sanitizer"
+ 80
+ (config-with-sanitizer-port (config-with-sanitizer)))
+
+ (test-equal "string value, sanitized to number"
+ 56
+ (config-with-sanitizer-port (config-with-sanitizer
+ (port "56"))))
+
+ (define (custom-serialize-port field-name value)
+ (number->string value))
+
+ (define-configuration config-serializer
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ (serializer custom-serialize-port)))
+
+ (test-equal "default value, serializer literal"
+ "80"
+ (eval-gexp
+ (serialize-configuration (config-serializer)
+ config-serializer-fields))))
+
+(test-group "empty-serializer as literal/procedure tests"
+ ;; empty-serializer as literal
+ (define-configuration config-with-literal
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ empty-serializer))
+
+ ;; empty-serializer as procedure
+ (define-configuration config-with-proc
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ (serializer empty-serializer)))
+
+ (test-equal "empty-serializer as literal"
+ ""
+ (eval-gexp
+ (serialize-configuration (config-with-literal)
+ config-with-literal-fields)))
+
+ (test-equal "empty-serializer as procedure"
+ ""
+ (eval-gexp
+ (serialize-configuration (config-with-proc)
+ config-with-proc-fields))))
+
+(test-group "permutation tests"
+ (define-configuration config-san+empty-ser
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ (sanitizer sanitize-port)
+ empty-serializer))
+
+ (define-configuration config-san+ser
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ (sanitizer sanitize-port)
+ (serializer (lambda _ "foo"))))
+
+ (test-equal "default value, sanitizer, permutation"
+ 80
+ (config-san+empty-ser-port (config-san+empty-ser)))
+
+ (test-equal "default value, serializer, permutation"
+ "foo"
+ (eval-gexp
+ (serialize-configuration (config-san+ser) config-san+ser-fields)))
+
+ (test-equal "string value sanitized to number, permutation"
+ 56
+ (config-san+ser-port (config-san+ser
+ (port "56"))))
+
+ ;; ordering tests
+ (define-configuration config-ser+san
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ (sanitizer sanitize-port)
+ (serializer (lambda _ "foo"))))
+
+ (define-configuration config-empty-ser+san
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ empty-serializer
+ (sanitizer sanitize-port)))
+
+ (test-equal "default value, sanitizer, permutation 2"
+ 56
+ (config-empty-ser+san-port (config-empty-ser+san
+ (port "56"))))
+
+ (test-equal "default value, serializer, permutation 2"
+ "foo"
+ (eval-gexp
+ (serialize-configuration (config-ser+san) config-ser+san-fields))))
+
+(test-group "duplicated/conflicting entries"
+ (test-error
+ "duplicate sanitizer" #t
+ (macroexpand '(define-configuration dupe-san
+ (foo
+ (list '())
+ "Lorem Ipsum."
+ (sanitizer (lambda () #t))
+ (sanitizer (lambda () #t))))))
+
+ (test-error
+ "duplicate serializer" #t
+ (macroexpand '(define-configuration dupe-ser
+ (foo
+ (list '())
+ "Lorem Ipsum."
+ (serializer (lambda _ ""))
+ (serializer (lambda _ ""))))))
+
+ (test-error
+ "conflicting use of serializer + empty-serializer" #t
+ (macroexpand '(define-configuration ser+empty-ser
+ (foo
+ (list '())
+ "Lorem Ipsum."
+ (serializer (lambda _ "lorem"))
+ empty-serializer)))))
+
+(test-group "Mix of deprecated and new syntax"
+ (test-error
+ "Mix of bare serializer and new syntax" #t
+ (macroexpand '(define-configuration mixed
+ (foo
+ (list '())
+ "Lorem Ipsum."
+ (sanitizer (lambda () #t))
+ (lambda _ "lorem")))))
+
+ (test-error
+ "Mix of bare serializer and new syntax, permutation)" #t
+ (macroexpand '(define-configuration mixed
+ (foo
+ (list '())
+ "Lorem Ipsum."
+ (lambda _ "lorem")
+ (sanitizer (lambda () #t)))))))
+
\f
;;;
;;; define-maybe macro.
--
2.39.1
next prev parent reply other threads:[~2023-03-23 15:03 UTC|newest]
Thread overview: 47+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-03-20 16:45 [bug#62298] [PATCH 0/8] Extensible define-configuration & mpd/mympd service fixes Bruno Victal
2023-03-20 17:07 ` [bug#62298] [PATCH 1/8] services: configuration: Add user-defined sanitizer support Bruno Victal
2023-03-20 19:43 ` Liliana Marie Prikler
2023-03-20 17:07 ` [bug#62298] [PATCH 2/8] services: replace bare serializers with (serializer ...) Bruno Victal
2023-03-20 17:07 ` [bug#62298] [PATCH 3/8] services: audio: remove redundant list-of-string? predicate Bruno Victal
2023-03-20 17:07 ` [bug#62298] [PATCH 4/8] services: mympd: Require 'syslog service when configured to log to syslog Bruno Victal
2023-03-20 17:07 ` [bug#62298] [PATCH 5/8] services: mpd: Fix unintentional API breakage for mixer-type field Bruno Victal
2023-03-20 17:07 ` [bug#62298] [PATCH 6/8] services: mpd: Set PulseAudio related variables as default value for environment-variables field Bruno Victal
2023-03-20 17:07 ` [bug#62298] [PATCH 7/8] services: mpd: Use user-account (resp. user-group) for user (resp. group) fields Bruno Victal
2023-03-20 19:33 ` Liliana Marie Prikler
2023-03-21 2:10 ` Bruno Victal
2023-03-21 5:30 ` Liliana Marie Prikler
2023-03-20 17:07 ` [bug#62298] [PATCH 8/8] services: mympd: " Bruno Victal
2023-03-20 19:33 ` Liliana Marie Prikler
2023-03-23 15:02 ` Bruno Victal [this message]
2023-03-23 15:02 ` [bug#62298] [PATCH v2 2/8] services: replace bare serializers with (serializer ...) Bruno Victal
2023-03-24 14:28 ` Maxim Cournoyer
2023-03-23 15:02 ` [bug#62298] [PATCH v2 3/8] services: audio: remove redundant list-of-string? predicate Bruno Victal
2023-03-23 15:02 ` [bug#62298] [PATCH v2 4/8] services: mympd: Require 'syslog service when configured to log to syslog Bruno Victal
2023-03-24 14:32 ` Maxim Cournoyer
2023-03-23 15:02 ` [bug#62298] [PATCH v2 5/8] services: mpd: Fix unintentional API breakage for mixer-type field Bruno Victal
2023-03-23 15:02 ` [bug#62298] [PATCH v2 6/8] services: mpd: Set PulseAudio related variables as default value for environment-variables field Bruno Victal
2023-03-24 18:10 ` bug#62298: " Maxim Cournoyer
2023-03-23 15:02 ` [bug#62298] [PATCH v2 7/8] services: mpd: Use user-account (resp. user-group) for user (resp. group) fields Bruno Victal
2023-03-23 18:03 ` Liliana Marie Prikler
2023-03-24 15:31 ` Maxim Cournoyer
2023-03-23 15:02 ` [bug#62298] [PATCH v2 8/8] services: mympd: " Bruno Victal
2023-03-23 19:19 ` Liliana Marie Prikler
2023-03-25 0:39 ` Bruno Victal
2023-03-24 16:03 ` Maxim Cournoyer
2023-03-25 0:33 ` Bruno Victal
2023-03-25 5:21 ` Liliana Marie Prikler
2023-03-23 19:47 ` [bug#62298] [PATCH v2 1/8] services: configuration: Add user-defined sanitizer support Liliana Marie Prikler
2023-03-24 14:25 ` Maxim Cournoyer
2023-03-24 18:03 ` Liliana Marie Prikler
2023-03-26 2:01 ` Maxim Cournoyer
2023-03-25 0:46 ` [bug#62298] [PATCH v3 1/5] " Bruno Victal
2023-03-25 0:46 ` [bug#62298] [PATCH v3 2/5] services: replace bare serializers with (serializer ...) Bruno Victal
2023-03-25 0:46 ` [bug#62298] [PATCH v3 3/5] services: mpd: Fix unintentional API breakage for mixer-type field Bruno Victal
2023-03-25 0:46 ` [bug#62298] [PATCH v3 4/5] services: mpd: Use user-account (resp. user-group) for user (resp. group) fields Bruno Victal
2023-03-25 0:46 ` [bug#62298] [PATCH v3 5/5] services: mympd: " Bruno Victal
2023-03-26 18:41 ` [bug#62298] [PATCH v4 1/5] services: configuration: Add user-defined sanitizer support Bruno Victal
2023-03-26 18:41 ` [bug#62298] [PATCH v4 2/5] services: replace bare serializers with (serializer ...) Bruno Victal
2023-03-26 18:41 ` [bug#62298] [PATCH v4 3/5] services: mpd: Fix unintentional API breakage for mixer-type field Bruno Victal
2023-03-26 18:41 ` [bug#62298] [PATCH v4 4/5] services: mpd: Use user-account (resp. user-group) for user (resp. group) fields Bruno Victal
2023-03-26 18:41 ` [bug#62298] [PATCH v4 5/5] services: mympd: " Bruno Victal
2023-04-02 10:46 ` bug#62298: [PATCH v4 1/5] services: configuration: Add user-defined sanitizer support Liliana Marie Prikler
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=e251c56b622dd0324bb4fd38cf65d0a04c8f12fa.1679583701.git.mirai@makinata.eu \
--to=mirai@makinata.eu \
--cc=62298@debbugs.gnu.org \
--cc=liliana.prikler@gmail.com \
--cc=ludo@gnu.org \
--cc=maxim.cournoyer@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).