diff options
| -rw-r--r-- | doc/guix.texi | 29 | ||||
| -rw-r--r-- | gnu/services/configuration.scm | 90 | ||||
| -rw-r--r-- | tests/services/configuration.scm | 183 |
3 files changed, 276 insertions, 26 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index a58ea8f9ec..495a930d0d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index ed9d95f906..367b85c1be 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 @@ #: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 () diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm index 4f8a74dc8a..0392cce927 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 @@ #: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 @@ -111,6 +113,183 @@ ;;; +;;; 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. ;;; (define-maybe number) |