summaryrefslogtreecommitdiff
path: root/gnu/services/configuration.scm
diff options
context:
space:
mode:
authorBruno Victal <mirai@makinata.eu>2023-03-26 19:41:29 +0100
committerLiliana Marie Prikler <liliana.prikler@gmail.com>2023-04-02 12:31:51 +0200
commit6f48efa9b89f3c33f7b2827cae88e87ec64faa09 (patch)
tree23a236dd58239e625aa540d68cbd833f40371af5 /gnu/services/configuration.scm
parent2ebbe8e9df66d6607cafa38a79926e4c9ac0d151 (diff)
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>
Diffstat (limited to 'gnu/services/configuration.scm')
-rw-r--r--gnu/services/configuration.scm90
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 ()