aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/services/configuration.scm55
-rw-r--r--gnu/services/mail.scm2
-rw-r--r--po/guix/POTFILES.in1
-rw-r--r--tests/services/configuration.scm13
4 files changed, 58 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)
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 201e5dcc87..f50dd00422 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -4,6 +4,7 @@ gnu.scm
gnu/packages.scm
gnu/services.scm
gnu/system.scm
+gnu/services/configuration.scm
gnu/services/shepherd.scm
gnu/home/services.scm
gnu/home/services/ssh.scm
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 334a1e409b..6268525317 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,6 +20,7 @@
(define-module (tests services configuration)
#:use-module (gnu services configuration)
+ #:use-module (guix diagnostics)
#:use-module (guix gexp)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64))
@@ -43,6 +45,17 @@
80
(port-configuration-port (port-configuration)))
+(test-equal "wrong type for a field"
+ '("configuration.scm" 57 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!
+ (port "This is not a number!"))))
+
(define-configuration port-configuration-cs
(port (number 80) "The port number." empty-serializer))