diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/services/configuration.scm | 55 | ||||
| -rw-r--r-- | gnu/services/mail.scm | 2 |
2 files changed, 44 insertions, 13 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index f6b20fb82b..c39ea5a02a 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -27,7 +27,8 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module ((guix utils) #:select (source-properties->location)) - #:use-module ((guix diagnostics) #:select (formatted-message location-file)) + #:use-module ((guix diagnostics) + #:select (formatted-message location-file &error-location)) #:use-module ((guix modules) #:select (file-name->module-name)) #:use-module (guix i18n) #:autoload (texinfo) (texi-fragment->stexi) @@ -87,9 +88,17 @@ (define (configuration-error message) (raise (condition (&message (message message)) (&configuration-error)))) -(define (configuration-field-error field val) - (configuration-error - (format #f "Invalid value for field ~a: ~s" field val))) +(define (configuration-field-error loc field value) + (raise (apply + make-compound-condition + (formatted-message (G_ "invalid value ~s for field '~a'") + value field) + (condition (&configuration-error)) + (if loc + (list (condition + (&error-location (location loc)))) + '())))) + (define (configuration-missing-field kind field) (configuration-error (format #f "~a configuration missing required field ~a" kind field))) @@ -210,9 +219,33 @@ does not have a default value" field kind))) (id #'stem #'serialize- type)))))) #'(field-type ...) #'((custom-serializer ...) ...)))) + (define (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. + #`(define-syntax #,(id #'stem #'validate- #'stem #'- name) + (lambda (s) + ;; Make sure the given VALUE, for field NAME, passes PRED. + (syntax-case s () + ((_ value) + (with-syntax ((name #'#,name) + (pred #'#,pred) + (loc (datum->syntax #'value + (syntax-source #'value)))) + #'(if (pred value) + value + (configuration-field-error + (and=> 'loc source-properties->location) + 'name value)))))))) + #`(begin + ;; Define field validation macros. + #,@(map field-sanitizer + #'(field ...) + #'(field-predicate ...)) + (define-record-type* #,(id #'stem #'< #'stem #'>) - #,(id #'stem #'% #'stem) + stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?) (%location #,(id #'stem #'stem #'-location) @@ -220,10 +253,13 @@ does not have a default value" field kind))) source-properties->location)) (innate)) #,@(map (lambda (name getter def) - #`(#,name #,getter (default #,def))) + #`(#,name #,getter (default #,def) + (sanitize + #,(id #'stem #'validate- #'stem #'- name)))) #'(field ...) #'(field-getter ...) #'(field-default ...))) + (define #,(id #'stem #'stem #'-fields) (list (configuration-field (name 'field) @@ -240,12 +276,7 @@ does not have a default value" field kind))) '#,(id #'stem #'% #'stem) 'field) field-default))) (documentation doc)) - ...)) - (define-syntax-rule (stem arg (... ...)) - (let ((conf (#,(id #'stem #'% #'stem) arg (... ...)))) - (validate-configuration conf - #,(id #'stem #'stem #'-fields)) - conf)))))))) + ...)))))))) (define no-serialization ;syntactic keyword for 'define-configuration' '(no serialization)) diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm index d99743ac31..c2fd4d8670 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -285,7 +285,7 @@ the section name.") (serialize-fifo-listener-configuration field-name val)) ((inet-listener-configuration? val) (serialize-inet-listener-configuration field-name val)) - (else (configuration-field-error field-name val)))) + (else (configuration-field-error #f field-name val)))) (define (listener-configuration-list? val) (and (list? val) (and-map listener-configuration? val))) (define (serialize-listener-configuration-list field-name val) |