aboutsummaryrefslogtreecommitdiff
path: root/gnu/services/mail.scm
diff options
context:
space:
mode:
authorJulien Lepiller <julien@lepiller.eu>2016-11-23 21:43:42 +0100
committerLudovic Courtès <ludo@gnu.org>2016-11-26 19:46:01 +0100
commit5305ed20027a32ff1221cac6a131849852e807ba (patch)
tree6f813f4a070cdecaa3ef35f0690c952c04ca8d8a /gnu/services/mail.scm
parentcf3678df6e1bdbb4bf80d2fae041be69eec2cd67 (diff)
downloadguix-5305ed20027a32ff1221cac6a131849852e807ba.tar
guix-5305ed20027a32ff1221cac6a131849852e807ba.tar.gz
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>
Diffstat (limited to 'gnu/services/mail.scm')
-rw-r--r--gnu/services/mail.scm183
1 files changed, 15 insertions, 168 deletions
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index f7ab9516ba..c1381405d8 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -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))
;;;