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:
parent
cf3678df6e
commit
5305ed2002
|
@ -399,6 +399,7 @@ GNU_SYSTEM_MODULES = \
|
|||
%D%/services/admin.scm \
|
||||
%D%/services/avahi.scm \
|
||||
%D%/services/base.scm \
|
||||
%D%/services/configuration.scm \
|
||||
%D%/services/cups.scm \
|
||||
%D%/services/databases.scm \
|
||||
%D%/services/dbus.scm \
|
||||
|
|
|
@ -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))))
|
|
@ -19,6 +19,7 @@
|
|||
(define-module (gnu services cups)
|
||||
#:use-module (gnu services)
|
||||
#:use-module (gnu services shepherd)
|
||||
#:use-module (gnu services configuration)
|
||||
#:use-module (gnu system shadow)
|
||||
#:use-module (gnu packages admin)
|
||||
#:use-module (gnu packages cups)
|
||||
|
@ -26,16 +27,9 @@
|
|||
#:use-module (guix packages)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (texinfo)
|
||||
#:use-module (texinfo serialize)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module ((srfi srfi-1) #:select (append-map))
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:export (&cups-configuation-error
|
||||
cups-configuration-error?
|
||||
|
||||
cups-service-type
|
||||
#:export (cups-service-type
|
||||
cups-configuration
|
||||
opaque-cups-configuration
|
||||
|
||||
|
@ -51,91 +45,6 @@
|
|||
;;;
|
||||
;;; 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
|
||||
(list (user-group (name "lp") (system? #t))
|
||||
(user-group (name "lpadmin") (system? #t))
|
||||
|
@ -147,24 +56,6 @@
|
|||
(home-directory "/var/empty")
|
||||
(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)
|
||||
(and (list? val)
|
||||
(and-map (lambda (x)
|
||||
|
@ -173,28 +64,11 @@
|
|||
(define (serialize-multiline-string-list field-name 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)
|
||||
(and (list? val) (and-map symbol? val)))
|
||||
(define (serialize-space-separated-symbol-list field-name 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)
|
||||
(and (exact-integer? val) (not (negative? val))))
|
||||
(define (serialize-non-negative-integer field-name val)
|
||||
|
@ -333,7 +207,7 @@ methods. Otherwise apply to only the listed methods.")
|
|||
|
||||
(define-configuration location-access-control
|
||||
(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.")
|
||||
(access-controls
|
||||
(access-control-list '())
|
||||
|
@ -359,7 +233,7 @@ methods. Otherwise apply to only the listed methods.")
|
|||
|
||||
(define-configuration policy-configuration
|
||||
(name
|
||||
(string (cups-configuration-missing-field 'policy-configuration 'name))
|
||||
(string (configuration-missing-field 'policy-configuration 'name))
|
||||
"Name of the policy.")
|
||||
(job-private-access
|
||||
(string "@OWNER @SYSTEM")
|
||||
|
@ -925,12 +799,12 @@ IPP specifications.")
|
|||
(package-list '())
|
||||
"Drivers and other extensions to the CUPS package.")
|
||||
(cupsd.conf
|
||||
(string (cups-configuration-missing-field 'opaque-cups-configuration
|
||||
'cupsd.conf))
|
||||
(string (configuration-missing-field 'opaque-cups-configuration
|
||||
'cupsd.conf))
|
||||
"The contents of the @code{cupsd.conf} to use.")
|
||||
(cups-files.conf
|
||||
(string (cups-configuration-missing-field 'opaque-cups-configuration
|
||||
'cups-files.conf))
|
||||
(string (configuration-missing-field 'opaque-cups-configuration
|
||||
'cups-files.conf))
|
||||
"The contents of the @code{cups-files.conf} to use."))
|
||||
|
||||
(define %cups-activation
|
||||
|
@ -1117,8 +991,8 @@ extensions that it uses."
|
|||
extensions)))))))))
|
||||
|
||||
;; A little helper to make it easier to document all those fields.
|
||||
(define (generate-documentation)
|
||||
(define documentation
|
||||
(define (generate-cups-documentation)
|
||||
(generate-documentation
|
||||
`((cups-configuration
|
||||
,cups-configuration-fields
|
||||
(files-configuration files-configuration)
|
||||
|
@ -1132,35 +1006,5 @@ extensions that it uses."
|
|||
,location-access-control-fields
|
||||
(method-access-controls method-access-controls))
|
||||
(operation-access-controls ,operation-access-control-fields)
|
||||
(method-access-controls ,method-access-control-fields)))
|
||||
(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 'cups-configuration))))
|
||||
(method-access-controls ,method-access-control-fields))
|
||||
'cups-configuration))
|
||||
|
|
|
@ -21,6 +21,7 @@
|
|||
(define-module (gnu services mail)
|
||||
#:use-module (gnu services)
|
||||
#:use-module (gnu services base)
|
||||
#:use-module (gnu services configuration)
|
||||
#:use-module (gnu services shepherd)
|
||||
#:use-module (gnu system pam)
|
||||
#:use-module (gnu system shadow)
|
||||
|
@ -30,13 +31,8 @@
|
|||
#:use-module (guix records)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (&dovecot-configuation-error
|
||||
dovecot-configuration-error?
|
||||
|
||||
dovecot-service
|
||||
#:export (dovecot-service
|
||||
dovecot-service-type
|
||||
dovecot-configuration
|
||||
opaque-dovecot-configuration
|
||||
|
@ -65,112 +61,6 @@
|
|||
;;;
|
||||
;;; 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)
|
||||
(and (list? val)
|
||||
|
@ -180,12 +70,6 @@
|
|||
(define (serialize-comma-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 (colon-separated-file-name-list? val)
|
||||
(and (list? val)
|
||||
;; Trailing slashes not needed and not
|
||||
|
@ -193,9 +77,6 @@
|
|||
(define (serialize-colon-separated-file-name-list field-name 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)
|
||||
(and (exact-integer? val) (not (negative? val))))
|
||||
(define (serialize-non-negative-integer field-name val)
|
||||
|
@ -276,7 +157,7 @@
|
|||
|
||||
(define-configuration unix-listener-configuration
|
||||
(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.")
|
||||
(mode
|
||||
(string "0600")
|
||||
|
@ -295,7 +176,7 @@
|
|||
|
||||
(define-configuration fifo-listener-configuration
|
||||
(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.")
|
||||
(mode
|
||||
(string "0600")
|
||||
|
@ -314,14 +195,14 @@
|
|||
|
||||
(define-configuration inet-listener-configuration
|
||||
(protocol
|
||||
(string (dovecot-configuration-missing-field 'inet-listener 'protocol))
|
||||
(string (configuration-missing-field 'inet-listener 'protocol))
|
||||
"The protocol to listen for.")
|
||||
(address
|
||||
(string "")
|
||||
"The address on which to listen, or empty for all addresses.")
|
||||
(port
|
||||
(non-negative-integer
|
||||
(dovecot-configuration-missing-field 'inet-listener 'port))
|
||||
(configuration-missing-field 'inet-listener 'port))
|
||||
"The port on which to listen.")
|
||||
(ssl?
|
||||
(boolean #t)
|
||||
|
@ -345,7 +226,7 @@
|
|||
(serialize-fifo-listener-configuration field-name val))
|
||||
((inet-listener-configuration? 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)
|
||||
(and (list? val) (and-map listener-configuration? val)))
|
||||
(define (serialize-listener-configuration-list field-name val)
|
||||
|
@ -355,7 +236,7 @@
|
|||
|
||||
(define-configuration service-configuration
|
||||
(kind
|
||||
(string (dovecot-configuration-missing-field 'service 'kind))
|
||||
(string (configuration-missing-field 'service 'kind))
|
||||
"The service kind. Valid values include @code{director},
|
||||
@code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap},
|
||||
@code{pop3}, @code{auth}, @code{auth-worker}, @code{dict},
|
||||
|
@ -393,7 +274,7 @@ this."))
|
|||
|
||||
(define-configuration protocol-configuration
|
||||
(name
|
||||
(string (dovecot-configuration-missing-field 'protocol 'name))
|
||||
(string (configuration-missing-field 'protocol 'name))
|
||||
"The name of the protocol.")
|
||||
(auth-socket-path
|
||||
(string "/var/run/dovecot/auth-userdb")
|
||||
|
@ -1497,8 +1378,8 @@ greyed out, instead of only later giving \"not selectable\" popup error.
|
|||
"The dovecot package.")
|
||||
|
||||
(string
|
||||
(string (dovecot-configuration-missing-field 'opaque-dovecot-configuration
|
||||
'string))
|
||||
(string (configuration-missing-field 'opaque-dovecot-configuration
|
||||
'string))
|
||||
"The contents of the @code{dovecot.conf} to use."))
|
||||
|
||||
(define %dovecot-accounts
|
||||
|
@ -1634,8 +1515,8 @@ by @code{dovecot-configuration}. @var{config} may also be created by
|
|||
(service dovecot-service-type config))
|
||||
|
||||
;; A little helper to make it easier to document all those fields.
|
||||
(define (generate-documentation)
|
||||
(define documentation
|
||||
(define (generate-dovecot-documentation)
|
||||
(generate-documentation
|
||||
`((dovecot-configuration
|
||||
,dovecot-configuration-fields
|
||||
(dict dict-configuration)
|
||||
|
@ -1660,42 +1541,8 @@ by @code{dovecot-configuration}. @var{config} may also be created by
|
|||
,service-configuration-fields
|
||||
(listeners unix-listener-configuration fifo-listener-configuration
|
||||
inet-listener-configuration))
|
||||
(protocol-configuration ,protocol-configuration-fields)))
|
||||
(define (generate configuration-name)
|
||||
(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))
|
||||
(protocol-configuration ,protocol-configuration-fields))
|
||||
'dovecot-configuration))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
Loading…
Reference in New Issue