me
/
guix
Archived
1
0
Fork 0
Code

services: configuration: Add user-defined sanitizer support. 

This changes the 'custom-serializer' field into a generic
'extra-args' field that can be extended to support new literals.
Within extra-args, the literals 'sanitizer' and 'serializer' allow
for user-defined sanitization and serialization procedures respectively.
The 'empty-serializer' was also added as a literal to be used as before.

To prevent confusion between the new “explicit” style of specifying
a sanitizer, and the old “implicit” style, the latter has been
deprecated, and a warning is issued if it is encountered.

* 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 variable.
(<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.

Signed-off-by: Liliana Marie Prikler <liliana.prikler@gmail.com>
master
Bruno Victal 2023-03-26 19:41:29 +01:00 committed by Liliana Marie Prikler
parent 2ebbe8e9df
commit 6f48efa9b8
No known key found for this signature in database
GPG Key ID: 442A84B8C70E2F87
3 changed files with 276 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
doc/guix.texi
View File

@ -41219,7 +41219,7 @@ A clause can have one of the following forms:
(@var{field-name}
(@var{type} @var{default-value})
@var{documentation}
@var{serializer})
(serializer @var{serializer}))
(@var{field-name}
(@var{type})
@ -41228,7 +41228,18 @@ A clause can have one of the following forms:
(@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
@ -41251,6 +41262,20 @@ an object of the record type.
@var{documentation} is a string formatted with Texinfo syntax which
should provide a description of what setting this field does.
@var{sanitizer} is a procedure which takes one argument,
a user-supplied value, and returns a ``sanitized'' value for the field.
If no sanitizer is specified, a default sanitizer is used, which raises
an error if the value is not of type @var{type}.
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 (error "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

90
gnu/services/configuration.scm
View File

@ -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 @@
#: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 @@
#: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 @@
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 @@ does not have a default value" field kind)))
(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,44 @@ does not have a default value" field kind)))
(values #'(field-type %unset-value)))))
(define (define-configuration-helper serialize? serializer-prefix syn)
(define (normalize-extra-args s)
"Extract and normalize arguments following @var{doc}."
(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.
(null? (filter-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 +238,18 @@ does not have a default value" field kind)))
((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 +270,29 @@ does not have a default value" field kind)))
#`(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 +304,9 @@ does not have a default value" field kind)))
(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 ()

183
tests/services/configuration.scm
View File

@ -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 @@
#: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 @@
(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,183 @@
(let ((config (configuration-with-prefix)))
(serialize-configuration config configuration-with-prefix-fields))))
;;;
;;; 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"
(define-configuration config-with-literal
(port
(port 80)
"Lorem Ipsum."
empty-serializer))
(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)))))))
;;;
;;; define-maybe macro.