Package: guix-patches;
Reported by: Bruno Victal <mirai <at> makinata.eu>
Date: Mon, 20 Mar 2023 16:47:01 UTC
Severity: normal
Tags: patch
Done: Liliana Marie Prikler <liliana.prikler <at> gmail.com>
Bug is archived. No further changes may be made.
Message #38 received at 62298 <at> debbugs.gnu.org (full text, mbox):
From: Liliana Marie Prikler <liliana.prikler <at> gmail.com> To: Bruno Victal <mirai <at> makinata.eu>, 62298 <at> debbugs.gnu.org Cc: ludo <at> gnu.org, maxim.cournoyer <at> gmail.com Subject: Re: [PATCH 1/8] services: configuration: Add user-defined sanitizer support. Date: Mon, 20 Mar 2023 20:43:29 +0100
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 <at> gmail.com>
> ;;; Copyright © 2021 Xinglu Chen <public <at> yoctocell.xyz>
> ;;; Copyright © 2022 Ludovic Courtès <ludo <at> gnu.org>
> +;;; Copyright © 2023 Bruno Victal <mirai <at> 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))))
>
> +
> +;;;
> +;;; 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.