[bug#62298] [PATCH 1/8] services: configuration: Add user-defined sanitizer support.

[Liliana Marie Prikler <liliana.prikler@gmail.com>]

Am Montag, dem 20.03.2023 um 17:07 +0000 schrieb Bruno Victal:
> +  ;; The get-… procedures perform scanning to @var{extra-args} to
> allow for
> +  ;; newly added fields to be specified in arbitrary order.
> +  (define (get-sanitizer s)
> +    (syntax-case s (sanitizer)
> +      (((sanitizer proc) _ ...)
> +       #'proc)
> +      ((_ tail ...)
> +       (get-sanitizer #'(tail ...)))
> +      (() %unset-value)))
> +
> +  (define (get-serializer s)
> +    (syntax-case s (serializer empty-serializer)
> +      (((serializer proc) _ ...)
> +       #'proc)
> +      ((empty-serializer _ ...)
> +       #'empty-serializer)
> +      ((_ tail ...)
> +       (get-serializer #'(tail ...)))
> +      (() %unset-value)))
Instead of doing two passes, try using good old named let to loop over
s and get serializer and sanitizer in one go.  Use #f for their
defaults so you can do (or serializer #'empty-serializer) and (or
sanitizer %unset-value).

>    (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 ...))))
> @@ -200,21 +242,23 @@ (define (define-configuration-helper serialize?
> serializer-prefix syn)
>                      ((field-type default-value)
>                       default-value))
>                    #'((field-type def) ...)))
> +            ((field-sanitizer ...)
> +             (map (compose maybe-value get-sanitizer)
> +                  #'((extra-args ...) ...)))
>              ((field-serializer ...)
> -             (map (lambda (type custom-serializer)
> +             (map (lambda (type extra-args)
>                      (and serialize?
> -                         (match custom-serializer
> -                           ((serializer)
> -                            serializer)
> -                           (()
> -                            (if serializer-prefix
> -                                (id #'stem
> -                                    serializer-prefix
> -                                    #'serialize- type)
> -                                (id #'stem #'serialize- type))))))
> +                         (or
> +                          (if (deprecated-style-serializer? extra-
> args)
> +                              (car extra-args)  ; strip outer
> parenthesis
> +                              #f)
> +                          (maybe-value (get-serializer extra-args))
> +                          (if serializer-prefix
> +                              (id #'stem serializer-prefix
> #'serialize- type)
> +                              (id #'stem #'serialize- type)))))
>                    #'(field-type ...)
> -                  #'((custom-serializer ...) ...))))
> -         (define (field-sanitizer name pred)
> +                  #'((extra-args ...) ...))))
> +         (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 +279,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 +313,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..c5569a9e50 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,145 @@ (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)))))
> +
> +(let ()
> +  ;; 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))))
> +
> +(let ()
> +  ;; 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))))
> +
> +(let ()
> +  ;; 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))))
> +
Also add a test case for double serializer and double sanitizer bugs.

Cheers