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

[Bruno Victal]

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 as 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.
(deprecated-style-serializer?): New predicate.
(get-sanitizer, get-serializer): 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   |  97 ++++++++++++++++-----
 tests/services/configuration.scm | 145 ++++++++++++++++++++++++++++++-
 3 files changed, 247 insertions(+), 25 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index fa9ea5a6ec..f84cadeeda 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -41127,7 +41127,7 @@ Complex Configurations
 (@var{field-name}
  (@var{type} @var{default-value})
  @var{documentation}
- @var{serializer})
+ (serializer @var{serializer}))
 
 (@var{field-name}
  (@var{type})
@@ -41136,7 +41136,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
@@ -41159,6 +41170,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 02d1aa1796..6ad9ade76d 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)
@@ -44,6 +46,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 +119,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,8 +185,46 @@ (define (normalize-field-type+def s)
      (values #'(field-type %unset-value)))))
 
 (define (define-configuration-helper serialize? serializer-prefix syn)
+
+  (define (deprecated-style-serializer? s)
+    ;; TODO: helper for deprecated style, remove later.
+    (syntax-case s ()
+      ;; Case 1. Nothing after 'doc'.
+      (() #f)
+      ;; Case 2. Bare serializer after 'doc'. [deprecated]
+      ;; Until this case is removed, don't forget to add a check for your
+      ;; newly added field/literal here.
+      (proc
+       (not (or (maybe-value-set? (get-serializer s))
+                (maybe-value-set? (get-sanitizer s))))
+       (begin
+         (warning #f (G_ "specifying serializers after documentation is \
+deprecated, use (serializer ~a) instead~%") (car (syntax->datum #'proc))) #t))
+      ;; Else, something after 'doc' in the updated style.
+      (else #f)))
+
+  ;; 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)))
+
   (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))))
 
+
+;;;
+;;; 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))))
+
 
 ;;;
 ;;; define-maybe macro.
-- 
2.39.1