11/12: services: configuration: Allow specifying prefix for serializer names.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 2ad896751c8f7104f139c3fd43cd632fd428ccd5
Author: Xinglu Chen <public@yoctocell.xyz>
AuthorDate: Sat Jun 12 21:17:08 2021 +0200

    services: configuration: Allow specifying prefix for serializer names.
    
    Sometimes two configurations might have the same types for their field 
values,
    but the values might be serialized in two completely different
    ways (e.g. because the two programs have different configuration languages).
    
    An example of this would be the ‘serialize-boolean’ procedure in (gnu 
services
    mail) and (gnu services getmail).  They both serialize a boolean value, but
    because the Dovecot’s configuration language has a different syntax to the
    configuration language for Getmail, two different procedures have to be
    defined.
    
    One way to workaround this would be to specify custom serializers for many
    fields in order to separate the serialization of the values that have the 
same
    type but serialize in different ways.  This could get very tedious, 
especially
    if there are many configurations in the same module.
    
    Another way would be to move one of the configurations to its own module, 
like
    what was done with (gnu services getmail).  However, this would mean that
    there would be multiple modules containing configurations for related
    programs, e.g. we have (gnu services mail) and (gnu services getmail), it
    doesn’t make much sense to keep the Getmail configuration in its own module.
    
    This patch will allow one to write something like this:
    
      (define-configuration foo-configuration
        (bar
          (string "bob")
          "Option bar.")
        (prefix bar-))
    
    and the value of the ‘bar’ field would be serialized using a procedure named
    ‘bar-serialize-string’ instead of just ‘serialize-string’.
    
    * gnu/services/configuration.scm (define-maybe-helper): Accept ‘prefix’
    argument for using serializer with custom prefix.
    (define-maybe): Pattern match on ‘prefix’ literal.
    (define-configuration-helper): Accept ‘prefix’ argument for using serializer
    with custom prefix.
    (define-configuration): Pattern match on ‘prefix’ literal.
    * tests/services/configuration.scm ("serialize-configuration with prefix"):
    New test.
    
    Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 gnu/services/configuration.scm   | 38 +++++++++++++++++++++++++++-----------
 tests/services/configuration.scm | 12 ++++++++++++
 2 files changed, 39 insertions(+), 11 deletions(-)

diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index f23840e..fd07b6f 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -109,14 +109,18 @@ does not have a default value" field kind)))
   "Assemble PARTS into a raw (unhygienic) identifier."
   (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
 
-(define (define-maybe-helper serialize? syn)
+(define (define-maybe-helper serialize? prefix syn)
   (syntax-case syn ()
     ((_ stem)
      (with-syntax
          ((stem?            (id #'stem #'stem #'?))
           (maybe-stem?      (id #'stem #'maybe- #'stem #'?))
-          (serialize-stem   (id #'stem #'serialize- #'stem))
-          (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
+          (serialize-stem   (if prefix
+                                (id #'stem prefix #'serialize- #'stem)
+                                (id #'stem #'serialize- #'stem)))
+          (serialize-maybe-stem (if prefix
+                                    (id #'stem prefix #'serialize-maybe- 
#'stem)
+                                    (id #'stem #'serialize-maybe- #'stem))))
        #`(begin
            (define (maybe-stem? val)
              (or (eq? val 'disabled) (stem? val)))
@@ -129,16 +133,18 @@ does not have a default value" field kind)))
 
 (define-syntax define-maybe
   (lambda (x)
-    (syntax-case x (no-serialization)
+    (syntax-case x (no-serialization prefix)
       ((_ stem (no-serialization))
-       (define-maybe-helper #f #'(_ stem)))
+       (define-maybe-helper #f #f #'(_ stem)))
+      ((_ stem (prefix serializer-prefix))
+       (define-maybe-helper #t #'serializer-prefix #'(_ stem)))
       ((_ stem)
-       (define-maybe-helper #t #'(_ stem))))))
+       (define-maybe-helper #t #f #'(_ stem))))))
 
 (define-syntax-rule (define-maybe/no-serialization stem)
   (define-maybe stem (no-serialization)))
 
-(define (define-configuration-helper serialize? syn)
+(define (define-configuration-helper serialize? serializer-prefix syn)
   (syntax-case syn ()
     ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
      (with-syntax (((field-getter ...)
@@ -165,7 +171,11 @@ does not have a default value" field kind)))
                                   ((serializer)
                                    serializer)
                                   (()
-                                  (id #'stem #'serialize- type)))))
+                                   (if serializer-prefix
+                                       (id #'stem
+                                           serializer-prefix
+                                           #'serialize- type)
+                                       (id #'stem #'serialize- type))))))
                          #'(field-type ...)
                          #'((custom-serializer ...) ...))))
        #`(begin
@@ -212,15 +222,21 @@ does not have a default value" field kind)))
 
 (define-syntax define-configuration
   (lambda (s)
-    (syntax-case s (no-serialization)
+    (syntax-case s (no-serialization prefix)
       ((_ stem (field (field-type def ...) doc custom-serializer ...) ...
           (no-serialization))
        (define-configuration-helper
-         #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
+         #f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
+                 ...)))
+      ((_ stem  (field (field-type def ...) doc custom-serializer ...) ...
+          (prefix serializer-prefix))
+       (define-configuration-helper
+         #t #'serializer-prefix #'(_ stem (field (field-type def ...)
+                                                 doc custom-serializer ...)
                  ...)))
       ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
        (define-configuration-helper
-         #t #'(_ stem (field (field-type def ...) doc custom-serializer ...)
+         #t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
                  ...))))))
 
 (define-syntax-rule (define-configuration/no-serialization
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 85badd2..86a36a3 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -82,6 +83,17 @@
         (let ((config (serializable-configuration)))
           (serialize-configuration config 
serializable-configuration-fields)))))
 
+(define (custom-prefix-serialize-integer field-name name) name)
+
+(define-configuration configuration-with-prefix
+  (port (integer 10) "The port number.")
+  (prefix custom-prefix-))
+
+(test-assert "serialize-configuration with prefix"
+  (gexp?
+   (let ((config (configuration-with-prefix)))
+     (serialize-configuration config configuration-with-prefix-fields))))
+
 
 ;;;
 ;;; define-maybe macro.