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>

1 files changed, 68 insertions, 22 deletions

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 ()