services: Factorize configuration abstraction.

* gnu/services/mail.scm and gnu/services/cups.scm (&configuration-error)
(configuration-error, configuration-field-error)
(configuration-missing-field, configuration-field, serialize-configuration)
(validate-configuration, define-configuration, uglify-field-name)
(serialize-field, serialize-package, serialize-string)
(serialize-space-separated-string-list, space-separated-string-list?)
(serialize-file-name, file-name?, serialize-field-name)
(generate-documentation): Move duplicate code...
* gnu/services/configuration.scm: ...to this new file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add configuration.scm.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Julien Lepiller 2016-11-23 21:43:42 +01:00 committed by Ludovic Courtès
parent cf3678df6e
commit 5305ed2002
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
4 changed files with 233 additions and 336 deletions

View file

@ -399,6 +399,7 @@ GNU_SYSTEM_MODULES = \
%D%/services/admin.scm \ %D%/services/admin.scm \
%D%/services/avahi.scm \ %D%/services/avahi.scm \
%D%/services/base.scm \ %D%/services/base.scm \
%D%/services/configuration.scm \
%D%/services/cups.scm \ %D%/services/cups.scm \
%D%/services/databases.scm \ %D%/services/databases.scm \
%D%/services/dbus.scm \ %D%/services/dbus.scm \

View file

@ -0,0 +1,205 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services configuration)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix gexp)
#:autoload (texinfo) (texi-fragment->stexi)
#:autoload (texinfo serialize) (stexi->texi)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (append-map))
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (configuration-field
configuration-field-name
configuration-missing-field
configuration-field-error
serialize-configuration
define-configuration
validate-configuration
generate-documentation
serialize-field
serialize-string
serialize-name
serialize-space-separated-string-list
space-separated-string-list?
serialize-file-name
file-name?
serialize-boolean
serialize-package))
;;; Commentary:
;;;
;;; Syntax for creating Scheme bindings to complex configuration files.
;;;
;;; Code:
(define-condition-type &configuration-error &error
configuration-error?)
(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-missing-field kind field)
(configuration-error
(format #f "~a configuration missing required field ~a" kind field)))
(define-record-type* <configuration-field>
configuration-field make-configuration-field configuration-field?
(name configuration-field-name)
(type configuration-field-type)
(getter configuration-field-getter)
(predicate configuration-field-predicate)
(serializer configuration-field-serializer)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
(define (serialize-configuration config fields)
(for-each (lambda (field)
((configuration-field-serializer field)
(configuration-field-name field)
((configuration-field-getter field) config)))
fields))
(define (validate-configuration config fields)
(for-each (lambda (field)
(let ((val ((configuration-field-getter field) config)))
(unless ((configuration-field-predicate field) val)
(configuration-field-error
(configuration-field-name field) val))))
fields))
(define-syntax define-configuration
(lambda (stx)
(define (id ctx part . parts)
(let ((part (syntax->datum part)))
(datum->syntax
ctx
(match parts
(() part)
(parts (symbol-append part
(syntax->datum (apply id ctx parts))))))))
(syntax-case stx ()
((_ stem (field (field-type def) doc) ...)
(with-syntax (((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-serializer ...)
(map (lambda (type)
(id #'stem #'serialize- type))
#'(field-type ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
#,(id #'stem #'% #'stem)
#,(id #'stem #'make- #'stem)
#,(id #'stem #'stem #'?)
(field field-getter (default def))
...)
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk (lambda () def))
(documentation doc))
...))
(define-syntax-rule (stem arg (... ...))
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
(validate-configuration conf
#,(id #'stem #'stem #'-fields))
conf))))))))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string-concatenate
(map string-titlecase
(string-split (if (string-suffix? "?" str)
(substring str 0 (1- (string-length str)))
str)
#\-)))))
(define (serialize-field field-name val)
(format #t "~a ~a\n" (uglify-field-name field-name) val))
(define (serialize-package field-name val)
#f)
(define (serialize-string field-name val)
(serialize-field field-name val))
(define (space-separated-string-list? val)
(and (list? val)
(and-map (lambda (x)
(and (string? x) (not (string-index x #\space))))
val)))
(define (serialize-space-separated-string-list field-name val)
(serialize-field field-name (string-join val " ")))
(define (file-name? val)
(and (string? val)
(string-prefix? "/" val)))
(define (serialize-file-name field-name val)
(serialize-string field-name val))
(define (serialize-boolean field-name val)
(serialize-string field-name (if val "yes" "no")))
;; A little helper to make it easier to document all those fields.
(define (generate-documentation documentation documentation-name)
(define (str x) (object->string x))
(define (generate configuration-name)
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
`((para "Available " (code ,(str configuration-name)) " fields are:")
,@(map
(lambda (f)
(let ((field-name (configuration-field-name f))
(field-type (configuration-field-type f))
(field-docs (cdr (texi-fragment->stexi
(configuration-field-documentation f))))
(default (catch #t
(configuration-field-default-value-thunk f)
(lambda _ '%invalid))))
(define (show-default? val)
(or (string? default) (number? default) (boolean? default)
(and (symbol? val) (not (eq? val '%invalid)))
(and (list? val) (and-map show-default? val))))
`(deftypevr (% (category
(code ,(str configuration-name)) " parameter")
(data-type ,(str field-type))
(name ,(str field-name)))
,@field-docs
,@(if (show-default? default)
`((para "Defaults to " (samp ,(str default)) "."))
'())
,@(append-map
generate
(or (assq-ref sub-documentation field-name) '())))))
fields)))))
(stexi->texi `(*fragment* . ,(generate documentation-name))))

View file

@ -19,6 +19,7 @@
(define-module (gnu services cups) (define-module (gnu services cups)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module (gnu services configuration)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages cups) #:use-module (gnu packages cups)
@ -26,16 +27,9 @@ (define-module (gnu services cups)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (texinfo)
#:use-module (texinfo serialize)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (append-map)) #:use-module ((srfi srfi-1) #:select (append-map))
#:use-module (srfi srfi-34) #:export (cups-service-type
#:use-module (srfi srfi-35)
#:export (&cups-configuation-error
cups-configuration-error?
cups-service-type
cups-configuration cups-configuration
opaque-cups-configuration opaque-cups-configuration
@ -51,91 +45,6 @@ (define-module (gnu services cups)
;;; ;;;
;;; Code: ;;; Code:
(define-condition-type &cups-configuration-error &error
cups-configuration-error?)
(define (cups-error message)
(raise (condition (&message (message message))
(&cups-configuration-error))))
(define (cups-configuration-field-error field val)
(cups-error
(format #f "Invalid value for field ~a: ~s" field val)))
(define (cups-configuration-missing-field kind field)
(cups-error
(format #f "~a configuration missing required field ~a" kind field)))
(define-record-type* <configuration-field>
configuration-field make-configuration-field configuration-field?
(name configuration-field-name)
(type configuration-field-type)
(getter configuration-field-getter)
(predicate configuration-field-predicate)
(serializer configuration-field-serializer)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
(define (serialize-configuration config fields)
(for-each (lambda (field)
((configuration-field-serializer field)
(configuration-field-name field)
((configuration-field-getter field) config)))
fields))
(define (validate-configuration config fields)
(for-each (lambda (field)
(let ((val ((configuration-field-getter field) config)))
(unless ((configuration-field-predicate field) val)
(cups-configuration-field-error
(configuration-field-name field) val))))
fields))
(define-syntax define-configuration
(lambda (stx)
(define (id ctx part . parts)
(let ((part (syntax->datum part)))
(datum->syntax
ctx
(match parts
(() part)
(parts (symbol-append part
(syntax->datum (apply id ctx parts))))))))
(syntax-case stx ()
((_ stem (field (field-type def) doc) ...)
(with-syntax (((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-serializer ...)
(map (lambda (type)
(id #'stem #'serialize- type))
#'(field-type ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
#,(id #'stem #'% #'stem)
#,(id #'stem #'make- #'stem)
#,(id #'stem #'stem #'?)
(field field-getter (default def))
...)
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk (lambda () def))
(documentation doc))
...))
(define-syntax-rule (stem arg (... ...))
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
(validate-configuration conf
#,(id #'stem #'stem #'-fields))
conf))))))))
(define %cups-accounts (define %cups-accounts
(list (user-group (name "lp") (system? #t)) (list (user-group (name "lp") (system? #t))
(user-group (name "lpadmin") (system? #t)) (user-group (name "lpadmin") (system? #t))
@ -147,24 +56,6 @@ (define %cups-accounts
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin"))))) (shell (file-append shadow "/sbin/nologin")))))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string-concatenate
(map string-titlecase
(string-split (if (string-suffix? "?" str)
(substring str 0 (1- (string-length str)))
str)
#\-)))))
(define (serialize-field field-name val)
(format #t "~a ~a\n" (uglify-field-name field-name) val))
(define (serialize-package field-name val)
#f)
(define (serialize-string field-name val)
(serialize-field field-name val))
(define (multiline-string-list? val) (define (multiline-string-list? val)
(and (list? val) (and (list? val)
(and-map (lambda (x) (and-map (lambda (x)
@ -173,28 +64,11 @@ (define (multiline-string-list? val)
(define (serialize-multiline-string-list field-name val) (define (serialize-multiline-string-list field-name val)
(for-each (lambda (str) (serialize-field field-name str)) val)) (for-each (lambda (str) (serialize-field field-name str)) val))
(define (space-separated-string-list? val)
(and (list? val)
(and-map (lambda (x)
(and (string? x) (not (string-index x #\space))))
val)))
(define (serialize-space-separated-string-list field-name val)
(serialize-field field-name (string-join val " ")))
(define (space-separated-symbol-list? val) (define (space-separated-symbol-list? val)
(and (list? val) (and-map symbol? val))) (and (list? val) (and-map symbol? val)))
(define (serialize-space-separated-symbol-list field-name val) (define (serialize-space-separated-symbol-list field-name val)
(serialize-field field-name (string-join (map symbol->string val) " "))) (serialize-field field-name (string-join (map symbol->string val) " ")))
(define (file-name? val)
(and (string? val)
(string-prefix? "/" val)))
(define (serialize-file-name field-name val)
(serialize-string field-name val))
(define (serialize-boolean field-name val)
(serialize-string field-name (if val "yes" "no")))
(define (non-negative-integer? val) (define (non-negative-integer? val)
(and (exact-integer? val) (not (negative? val)))) (and (exact-integer? val) (not (negative? val))))
(define (serialize-non-negative-integer field-name val) (define (serialize-non-negative-integer field-name val)
@ -333,7 +207,7 @@ (define (serialize-method-access-control-list field-name val)
(define-configuration location-access-control (define-configuration location-access-control
(path (path
(file-name (cups-configuration-missing-field 'location-access-control 'path)) (file-name (configuration-missing-field 'location-access-control 'path))
"Specifies the URI path to which the access control applies.") "Specifies the URI path to which the access control applies.")
(access-controls (access-controls
(access-control-list '()) (access-control-list '())
@ -359,7 +233,7 @@ (define (serialize-location-access-control-list field-name val)
(define-configuration policy-configuration (define-configuration policy-configuration
(name (name
(string (cups-configuration-missing-field 'policy-configuration 'name)) (string (configuration-missing-field 'policy-configuration 'name))
"Name of the policy.") "Name of the policy.")
(job-private-access (job-private-access
(string "@OWNER @SYSTEM") (string "@OWNER @SYSTEM")
@ -925,12 +799,12 @@ (define-configuration opaque-cups-configuration
(package-list '()) (package-list '())
"Drivers and other extensions to the CUPS package.") "Drivers and other extensions to the CUPS package.")
(cupsd.conf (cupsd.conf
(string (cups-configuration-missing-field 'opaque-cups-configuration (string (configuration-missing-field 'opaque-cups-configuration
'cupsd.conf)) 'cupsd.conf))
"The contents of the @code{cupsd.conf} to use.") "The contents of the @code{cupsd.conf} to use.")
(cups-files.conf (cups-files.conf
(string (cups-configuration-missing-field 'opaque-cups-configuration (string (configuration-missing-field 'opaque-cups-configuration
'cups-files.conf)) 'cups-files.conf))
"The contents of the @code{cups-files.conf} to use.")) "The contents of the @code{cups-files.conf} to use."))
(define %cups-activation (define %cups-activation
@ -1117,8 +991,8 @@ (define cups-service-type
extensions))))))))) extensions)))))))))
;; A little helper to make it easier to document all those fields. ;; A little helper to make it easier to document all those fields.
(define (generate-documentation) (define (generate-cups-documentation)
(define documentation (generate-documentation
`((cups-configuration `((cups-configuration
,cups-configuration-fields ,cups-configuration-fields
(files-configuration files-configuration) (files-configuration files-configuration)
@ -1132,35 +1006,5 @@ (define documentation
,location-access-control-fields ,location-access-control-fields
(method-access-controls method-access-controls)) (method-access-controls method-access-controls))
(operation-access-controls ,operation-access-control-fields) (operation-access-controls ,operation-access-control-fields)
(method-access-controls ,method-access-control-fields))) (method-access-controls ,method-access-control-fields))
(define (str x) (object->string x)) 'cups-configuration))
(define (generate configuration-name)
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
`((para "Available " (code ,(str configuration-name)) " fields are:")
,@(map
(lambda (f)
(let ((field-name (configuration-field-name f))
(field-type (configuration-field-type f))
(field-docs (cdr (texi-fragment->stexi
(configuration-field-documentation f))))
(default (catch #t
(configuration-field-default-value-thunk f)
(lambda _ '%invalid))))
(define (show-default? val)
(or (string? default) (number? default) (boolean? default)
(and (symbol? val) (not (eq? val '%invalid)))
(and (list? val) (and-map show-default? val))))
`(deftypevr (% (category
(code ,(str configuration-name)) " parameter")
(data-type ,(str field-type))
(name ,(str field-name)))
,@field-docs
,@(if (show-default? default)
`((para "Defaults to " (samp ,(str default)) "."))
'())
,@(append-map
generate
(or (assq-ref sub-documentation field-name) '())))))
fields)))))
(stexi->texi `(*fragment* . ,(generate 'cups-configuration))))

View file

@ -21,6 +21,7 @@
(define-module (gnu services mail) (define-module (gnu services mail)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services base) #:use-module (gnu services base)
#:use-module (gnu services configuration)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module (gnu system pam) #:use-module (gnu system pam)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
@ -30,13 +31,8 @@ (define-module (gnu services mail)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (&dovecot-configuation-error #:export (dovecot-service
dovecot-configuration-error?
dovecot-service
dovecot-service-type dovecot-service-type
dovecot-configuration dovecot-configuration
opaque-dovecot-configuration opaque-dovecot-configuration
@ -65,112 +61,6 @@ (define-module (gnu services mail)
;;; ;;;
;;; Code: ;;; Code:
(define-condition-type &dovecot-configuration-error &error
dovecot-configuration-error?)
(define (dovecot-error message)
(raise (condition (&message (message message))
(&dovecot-configuration-error))))
(define (dovecot-configuration-field-error field val)
(dovecot-error
(format #f "Invalid value for field ~a: ~s" field val)))
(define (dovecot-configuration-missing-field kind field)
(dovecot-error
(format #f "~a configuration missing required field ~a" kind field)))
(define-record-type* <configuration-field>
configuration-field make-configuration-field configuration-field?
(name configuration-field-name)
(type configuration-field-type)
(getter configuration-field-getter)
(predicate configuration-field-predicate)
(serializer configuration-field-serializer)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
(define-syntax define-configuration
(lambda (stx)
(define (id ctx part . parts)
(let ((part (syntax->datum part)))
(datum->syntax
ctx
(match parts
(() part)
(parts (symbol-append part
(syntax->datum (apply id ctx parts))))))))
(syntax-case stx ()
((_ stem (field (field-type def) doc) ...)
(with-syntax (((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-serializer ...)
(map (lambda (type)
(id #'stem #'serialize- type))
#'(field-type ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?)
(field field-getter (default def))
...)
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk (lambda () def))
(documentation doc))
...))))))))
(define (serialize-configuration config fields)
(for-each (lambda (field)
((configuration-field-serializer field)
(configuration-field-name field)
((configuration-field-getter field) config)))
fields))
(define (validate-configuration config fields)
(for-each (lambda (field)
(let ((val ((configuration-field-getter field) config)))
(unless ((configuration-field-predicate field) val)
(dovecot-configuration-field-error
(configuration-field-name field) val))))
fields))
(define (validate-package field-name package)
(unless (package? package)
(dovecot-configuration-field-error field-name package)))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string-join (string-split (if (string-suffix? "?" str)
(substring str 0 (1- (string-length str)))
str)
#\-)
"_")))
(define (serialize-package field-name val)
#f)
(define (serialize-field field-name val)
(format #t "~a=~a\n" (uglify-field-name field-name) val))
(define (serialize-string field-name val)
(serialize-field field-name val))
(define (space-separated-string-list? val)
(and (list? val)
(and-map (lambda (x)
(and (string? x) (not (string-index x #\space))))
val)))
(define (serialize-space-separated-string-list field-name val)
(serialize-field field-name (string-join val " ")))
(define (comma-separated-string-list? val) (define (comma-separated-string-list? val)
(and (list? val) (and (list? val)
@ -180,12 +70,6 @@ (define (comma-separated-string-list? val)
(define (serialize-comma-separated-string-list field-name val) (define (serialize-comma-separated-string-list field-name val)
(serialize-field field-name (string-join val ","))) (serialize-field field-name (string-join val ",")))
(define (file-name? val)
(and (string? val)
(string-prefix? "/" val)))
(define (serialize-file-name field-name val)
(serialize-string field-name val))
(define (colon-separated-file-name-list? val) (define (colon-separated-file-name-list? val)
(and (list? val) (and (list? val)
;; Trailing slashes not needed and not ;; Trailing slashes not needed and not
@ -193,9 +77,6 @@ (define (colon-separated-file-name-list? val)
(define (serialize-colon-separated-file-name-list field-name val) (define (serialize-colon-separated-file-name-list field-name val)
(serialize-field field-name (string-join val ":"))) (serialize-field field-name (string-join val ":")))
(define (serialize-boolean field-name val)
(serialize-string field-name (if val "yes" "no")))
(define (non-negative-integer? val) (define (non-negative-integer? val)
(and (exact-integer? val) (not (negative? val)))) (and (exact-integer? val) (not (negative? val))))
(define (serialize-non-negative-integer field-name val) (define (serialize-non-negative-integer field-name val)
@ -276,7 +157,7 @@ (define (serialize-userdb-configuration-list field-name val)
(define-configuration unix-listener-configuration (define-configuration unix-listener-configuration
(path (path
(file-name (dovecot-configuration-missing-field 'unix-listener 'path)) (file-name (configuration-missing-field 'unix-listener 'path))
"The file name on which to listen.") "The file name on which to listen.")
(mode (mode
(string "0600") (string "0600")
@ -295,7 +176,7 @@ (define (serialize-unix-listener-configuration field-name val)
(define-configuration fifo-listener-configuration (define-configuration fifo-listener-configuration
(path (path
(file-name (dovecot-configuration-missing-field 'fifo-listener 'path)) (file-name (configuration-missing-field 'fifo-listener 'path))
"The file name on which to listen.") "The file name on which to listen.")
(mode (mode
(string "0600") (string "0600")
@ -314,14 +195,14 @@ (define (serialize-fifo-listener-configuration field-name val)
(define-configuration inet-listener-configuration (define-configuration inet-listener-configuration
(protocol (protocol
(string (dovecot-configuration-missing-field 'inet-listener 'protocol)) (string (configuration-missing-field 'inet-listener 'protocol))
"The protocol to listen for.") "The protocol to listen for.")
(address (address
(string "") (string "")
"The address on which to listen, or empty for all addresses.") "The address on which to listen, or empty for all addresses.")
(port (port
(non-negative-integer (non-negative-integer
(dovecot-configuration-missing-field 'inet-listener 'port)) (configuration-missing-field 'inet-listener 'port))
"The port on which to listen.") "The port on which to listen.")
(ssl? (ssl?
(boolean #t) (boolean #t)
@ -345,7 +226,7 @@ (define (serialize-listener-configuration field-name val)
(serialize-fifo-listener-configuration field-name val)) (serialize-fifo-listener-configuration field-name val))
((inet-listener-configuration? val) ((inet-listener-configuration? val)
(serialize-inet-listener-configuration field-name val)) (serialize-inet-listener-configuration field-name val))
(else (dovecot-configuration-field-error field-name val)))) (else (configuration-field-error field-name val))))
(define (listener-configuration-list? val) (define (listener-configuration-list? val)
(and (list? val) (and-map listener-configuration? val))) (and (list? val) (and-map listener-configuration? val)))
(define (serialize-listener-configuration-list field-name val) (define (serialize-listener-configuration-list field-name val)
@ -355,7 +236,7 @@ (define (serialize-listener-configuration-list field-name val)
(define-configuration service-configuration (define-configuration service-configuration
(kind (kind
(string (dovecot-configuration-missing-field 'service 'kind)) (string (configuration-missing-field 'service 'kind))
"The service kind. Valid values include @code{director}, "The service kind. Valid values include @code{director},
@code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap}, @code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap},
@code{pop3}, @code{auth}, @code{auth-worker}, @code{dict}, @code{pop3}, @code{auth}, @code{auth-worker}, @code{dict},
@ -393,7 +274,7 @@ (define (serialize-service-configuration-list field-name val)
(define-configuration protocol-configuration (define-configuration protocol-configuration
(name (name
(string (dovecot-configuration-missing-field 'protocol 'name)) (string (configuration-missing-field 'protocol 'name))
"The name of the protocol.") "The name of the protocol.")
(auth-socket-path (auth-socket-path
(string "/var/run/dovecot/auth-userdb") (string "/var/run/dovecot/auth-userdb")
@ -1497,8 +1378,8 @@ (define-configuration opaque-dovecot-configuration
"The dovecot package.") "The dovecot package.")
(string (string
(string (dovecot-configuration-missing-field 'opaque-dovecot-configuration (string (configuration-missing-field 'opaque-dovecot-configuration
'string)) 'string))
"The contents of the @code{dovecot.conf} to use.")) "The contents of the @code{dovecot.conf} to use."))
(define %dovecot-accounts (define %dovecot-accounts
@ -1634,8 +1515,8 @@ (define* (dovecot-service #:key (config (dovecot-configuration)))
(service dovecot-service-type config)) (service dovecot-service-type config))
;; A little helper to make it easier to document all those fields. ;; A little helper to make it easier to document all those fields.
(define (generate-documentation) (define (generate-dovecot-documentation)
(define documentation (generate-documentation
`((dovecot-configuration `((dovecot-configuration
,dovecot-configuration-fields ,dovecot-configuration-fields
(dict dict-configuration) (dict dict-configuration)
@ -1660,42 +1541,8 @@ (define documentation
,service-configuration-fields ,service-configuration-fields
(listeners unix-listener-configuration fifo-listener-configuration (listeners unix-listener-configuration fifo-listener-configuration
inet-listener-configuration)) inet-listener-configuration))
(protocol-configuration ,protocol-configuration-fields))) (protocol-configuration ,protocol-configuration-fields))
(define (generate configuration-name) 'dovecot-configuration))
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
(format #t "\nAvailable @code{~a} fields are:\n\n" configuration-name)
(for-each
(lambda (f)
(let ((field-name (configuration-field-name f))
(field-type (configuration-field-type f))
(field-docs (string-trim-both
(configuration-field-documentation f)))
(default (catch #t
(configuration-field-default-value-thunk f)
(lambda _ 'nope))))
(define (escape-chars str chars escape)
(with-output-to-string
(lambda ()
(string-for-each (lambda (c)
(when (char-set-contains? chars c)
(display escape))
(display c))
str))))
(define (show-default? val)
(or (string? default) (number? default) (boolean? default)
(and (list? val) (and-map show-default? val))))
(format #t "@deftypevr {@code{~a} parameter} ~a ~a\n~a\n"
configuration-name field-type field-name field-docs)
(when (show-default? default)
(format #t "Defaults to @samp{~a}.\n"
(escape-chars (format #f "~s" default)
(char-set #\@ #\{ #\})
#\@)))
(for-each generate (or (assq-ref sub-documentation field-name) '()))
(format #t "@end deftypevr\n\n")))
fields))))
(generate 'dovecot-configuration))
;;; ;;;