* [PATCH] services: Make dovecot and cups configuration abstractions available
@ 2016-11-20 17:07 Julien Lepiller
2016-11-22 22:49 ` Ludovic Courtès
0 siblings, 1 reply; 9+ messages in thread
From: Julien Lepiller @ 2016-11-20 17:07 UTC (permalink / raw)
To: guix-devel
[-- Attachment #1: Type: text/plain, Size: 211 bytes --]
Hi,
since I will probably use it in openvpn-service and maybe in
nginx-service, I moved the definitions of the documentation that was
duplicated in cups and dovecot to services.scm. Is it the best place
for it?
[-- Attachment #2: 0001-services-Make-dovecot-and-cups-configuration-abstrac.patch --]
[-- Type: text/x-patch, Size: 28061 bytes --]
From 9acc9456f4e61506105bc109298aedb66e31efd0 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Sun, 20 Nov 2016 17:56:08 +0100
Subject: [PATCH] services: Make dovecot and cups configuration abstractions
available.
* gnu/services.scm: Add configuration-field, configuration-missing-field,
configuration-field-error, serialize-confgiuration, define-configuration,
validate-configuration, validate-configuration and generate-documetation.
* gnu/services/cups.scm: Use it.
* gnu/services/mail.scm: Use it.
---
gnu/services.scm | 134 ++++++++++++++++++++++++++++++++++++++-
gnu/services/cups.scm | 162 ++++++++++++-----------------------------------
gnu/services/mail.scm | 170 ++++++++++++++------------------------------------
3 files changed, 220 insertions(+), 246 deletions(-)
diff --git a/gnu/services.scm b/gnu/services.scm
index 693a7f8..abab1a6 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -28,6 +28,8 @@
#:use-module (guix modules)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
+ #:use-module (texinfo)
+ #:use-module (texinfo serialize)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
@@ -81,7 +83,16 @@
%activation-service
etc-service
- file-union)) ;XXX: for lack of a better place
+ file-union ;XXX: for lack of a better place
+
+ configuration-field
+ configuration-field-name
+ configuration-missing-field
+ configuration-field-error
+ serialize-configuration
+ define-configuration
+ validate-configuration
+ generate-documentation))
;;; Comment:
;;;
@@ -612,4 +623,125 @@ TARGET-TYPE; return the root service adjusted accordingly."
(_ "more than one target service of type '~a'")
(service-type-name target-type)))))))))
+(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 (generate-documentation documentation configuration-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 configuration-name))))
+
+
;;; services.scm ends here.
diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm
index 7542ee2..25e1d7c 100644
--- a/gnu/services/cups.scm
+++ b/gnu/services/cups.scm
@@ -26,8 +26,6 @@
#: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)
@@ -54,88 +52,6 @@
(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))
@@ -333,7 +249,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 +275,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 +841,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,7 +1033,8 @@ extensions that it uses."
extensions)))))))))
;; A little helper to make it easier to document all those fields.
-(define (generate-documentation)
+;(define (generate-documentation)
+(define (generate-cups-documentation)
(define documentation
`((cups-configuration
,cups-configuration-fields
@@ -1133,34 +1050,35 @@ extensions that it uses."
(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))))
+ (generate-documentation documentation 'cups-configuration))
+ ; (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))))
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index cb0f119..9db7ffa 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -60,87 +60,9 @@
;;;
;;; 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)))
+ (configuration-field-error field-name package)))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
@@ -271,7 +193,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")
@@ -290,7 +212,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")
@@ -309,14 +231,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)
@@ -340,7 +262,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)
@@ -350,7 +272,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},
@@ -388,7 +310,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")
@@ -1492,7 +1414,7 @@ greyed out, instead of only later giving \"not selectable\" popup error.
"The dovecot package.")
(string
- (string (dovecot-configuration-missing-field 'opaque-dovecot-configuration
+ (string (configuration-missing-field 'opaque-dovecot-configuration
'string))
"The contents of the @code{dovecot.conf} to use."))
@@ -1629,7 +1551,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 (generate-dovecot-documentation)
+;(define (generate-documentation)
(define documentation
`((dovecot-configuration
,dovecot-configuration-fields
@@ -1656,38 +1579,39 @@ by @code{dovecot-configuration}. @var{config} may also be created by
(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))
+ (generate-documentation documentation 'dovecot-configuration))
+ ; (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))
--
2.10.2
^ permalink raw reply related [flat|nested] 9+ messages in thread
* Re: [PATCH] services: Make dovecot and cups configuration abstractions available
2016-11-20 17:07 [PATCH] services: Make dovecot and cups configuration abstractions available Julien Lepiller
@ 2016-11-22 22:49 ` Ludovic Courtès
2016-11-23 21:08 ` Julien Lepiller
0 siblings, 1 reply; 9+ messages in thread
From: Ludovic Courtès @ 2016-11-22 22:49 UTC (permalink / raw)
To: Julien Lepiller; +Cc: guix-devel
Hi Julien,
Julien Lepiller <julien@lepiller.eu> skribis:
> since I will probably use it in openvpn-service and maybe in
> nginx-service, I moved the definitions of the documentation that was
> duplicated in cups and dovecot to services.scm. Is it the best place
> for it?
Thanks for looking into it!
I would suggest moving it to a new (gnu services configuration) module
instead, if that’s fine with you.
Could you send an updated patch?
BTW, I just checked and there’s at least one subtle difference between
cups.scm and mail.scm: ‘define-configuration’ in cups.scm defines the
constructor as a macro that calls ‘validate-configuration’:
(define-syntax-rule (stem arg (... ...))
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
(validate-configuration conf
#,(id #'stem #'stem #'-fields))
conf))
The version in mail.scm does not do that, but I think we want to
preserve it (and your patch does seem to preserve that already).
Probably the are serializers that can be factorized as well.
> From 9acc9456f4e61506105bc109298aedb66e31efd0 Mon Sep 17 00:00:00 2001
> From: Julien Lepiller <julien@lepiller.eu>
> Date: Sun, 20 Nov 2016 17:56:08 +0100
> Subject: [PATCH] services: Make dovecot and cups configuration abstractions
> available.
>
> * gnu/services.scm: Add configuration-field, configuration-missing-field,
> configuration-field-error, serialize-confgiuration, define-configuration,
> validate-configuration, validate-configuration and generate-documetation.
> * gnu/services/cups.scm: Use it.
> * gnu/services/mail.scm: Use it.
Please take some time to see the ChangeLog convention for this.
> + ; (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))
Why comment things out? Could it be moved to (gnu services
configuration) as well?
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] services: Make dovecot and cups configuration abstractions available
2016-11-22 22:49 ` Ludovic Courtès
@ 2016-11-23 21:08 ` Julien Lepiller
2016-11-23 21:46 ` Clément Lassieur
0 siblings, 1 reply; 9+ messages in thread
From: Julien Lepiller @ 2016-11-23 21:08 UTC (permalink / raw)
To: guix-devel
[-- Attachment #1: Type: text/plain, Size: 2597 bytes --]
On Tue, 22 Nov 2016 23:49:23 +0100
ludo@gnu.org (Ludovic Courtès) wrote:
> Hi Julien,
>
> Julien Lepiller <julien@lepiller.eu> skribis:
>
> > since I will probably use it in openvpn-service and maybe in
> > nginx-service, I moved the definitions of the documentation that was
> > duplicated in cups and dovecot to services.scm. Is it the best place
> > for it?
>
> Thanks for looking into it!
>
> I would suggest moving it to a new (gnu services configuration) module
> instead, if that’s fine with you.
>
> Could you send an updated patch?
Here it is ;)
>
> BTW, I just checked and there’s at least one subtle difference between
> cups.scm and mail.scm: ‘define-configuration’ in cups.scm defines the
> constructor as a macro that calls ‘validate-configuration’:
>
> (define-syntax-rule (stem arg (... ...))
> (let ((conf (#,(id #'stem #'% #'stem) arg
> (... ...)))) (validate-configuration conf
> #,(id #'stem #'stem
> #'-fields)) conf))
>
> The version in mail.scm does not do that, but I think we want to
> preserve it (and your patch does seem to preserve that already).
>
> Probably the are serializers that can be factorized as well.
I factorized what I saw that was in common between the two files in this
new patch.
>
> > From 9acc9456f4e61506105bc109298aedb66e31efd0 Mon Sep 17 00:00:00
> > 2001 From: Julien Lepiller <julien@lepiller.eu>
> > Date: Sun, 20 Nov 2016 17:56:08 +0100
> > Subject: [PATCH] services: Make dovecot and cups configuration
> > abstractions available.
> >
> > * gnu/services.scm: Add configuration-field,
> > configuration-missing-field, configuration-field-error,
> > serialize-confgiuration, define-configuration,
> > validate-configuration, validate-configuration and
> > generate-documetation.
> > * gnu/services/cups.scm: Use it.
> > * gnu/services/mail.scm: Use it.
>
> Please take some time to see the ChangeLog convention for this.
Is it better now?
>
> > + ; (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))
>
> Why comment things out? Could it be moved to (gnu services
> configuration) as well?
>
> Thanks!
>
> Ludo’.
[-- Attachment #2: 0001-services-factorize-configuration-abstraction.patch --]
[-- Type: text/x-patch, Size: 23593 bytes --]
From 5301dd605678686c1c37c0b6be92ff0d567ee63b Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Wed, 23 Nov 2016 21:43:42 +0100
Subject: [PATCH] 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 | 1 +
gnu/services/cups.scm | 180 ++++---------------------------------------------
gnu/services/mail.scm | 183 +++++---------------------------------------------
3 files changed, 28 insertions(+), 336 deletions(-)
diff --git a/gnu/local.mk b/gnu/local.mk
index 4913727..03f4ad4 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -400,6 +400,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 \
diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm
index 7542ee2..391046a 100644
--- a/gnu/services/cups.scm
+++ b/gnu/services/cups.scm
@@ -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))
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index cb0f119..4db0328 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
@@ -60,112 +56,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)
@@ -175,12 +65,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
@@ -188,9 +72,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)
@@ -271,7 +152,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")
@@ -290,7 +171,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")
@@ -309,14 +190,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)
@@ -340,7 +221,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)
@@ -350,7 +231,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},
@@ -388,7 +269,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")
@@ -1492,8 +1373,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
@@ -1629,8 +1510,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)
@@ -1655,39 +1536,5 @@ 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))
--
2.10.2
^ permalink raw reply related [flat|nested] 9+ messages in thread
* Re: [PATCH] services: Make dovecot and cups configuration abstractions available
2016-11-23 21:08 ` Julien Lepiller
@ 2016-11-23 21:46 ` Clément Lassieur
2016-11-24 13:25 ` Ludovic Courtès
0 siblings, 1 reply; 9+ messages in thread
From: Clément Lassieur @ 2016-11-23 21:46 UTC (permalink / raw)
To: Julien Lepiller; +Cc: guix-devel
>> I would suggest moving it to a new (gnu services configuration) module
>> instead, if that’s fine with you.
>>
>> Could you send an updated patch?
> Here it is ;)
I think you forgot to add gnu/services/configuration.scm to your patch :)
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] services: Make dovecot and cups configuration abstractions available
2016-11-23 21:46 ` Clément Lassieur
@ 2016-11-24 13:25 ` Ludovic Courtès
2016-11-24 18:17 ` Julien Lepiller
0 siblings, 1 reply; 9+ messages in thread
From: Ludovic Courtès @ 2016-11-24 13:25 UTC (permalink / raw)
To: Clément Lassieur; +Cc: guix-devel
Clément Lassieur <clement@lassieur.org> skribis:
>>> I would suggest moving it to a new (gnu services configuration) module
>>> instead, if that’s fine with you.
>>>
>>> Could you send an updated patch?
>> Here it is ;)
>
> I think you forgot to add gnu/services/configuration.scm to your patch :)
And the gnu/local.mk changes in the commit log.
Ludo'.
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] services: Make dovecot and cups configuration abstractions available
2016-11-24 13:25 ` Ludovic Courtès
@ 2016-11-24 18:17 ` Julien Lepiller
2016-11-26 8:49 ` John Darrington
2016-11-26 18:43 ` Ludovic Courtès
0 siblings, 2 replies; 9+ messages in thread
From: Julien Lepiller @ 2016-11-24 18:17 UTC (permalink / raw)
To: guix-devel
[-- Attachment #1: Type: text/plain, Size: 514 bytes --]
On Thu, 24 Nov 2016 14:25:05 +0100
ludo@gnu.org (Ludovic Courtès) wrote:
> Clément Lassieur <clement@lassieur.org> skribis:
>
> >>> I would suggest moving it to a new (gnu services configuration)
> >>> module instead, if that’s fine with you.
> >>>
> >>> Could you send an updated patch?
> >> Here it is ;)
> >
> > I think you forgot to add gnu/services/configuration.scm to your
> > patch :)
>
> And the gnu/local.mk changes in the commit log.
hm, sorry about that
>
> Ludo'.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-services-factorize-configuration-abstraction.patch --]
[-- Type: text/x-patch, Size: 33163 bytes --]
From 1b60fac10caa9ab05cf169206004f46b46f2db40 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Wed, 23 Nov 2016 21:43:42 +0100
Subject: [PATCH] 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.
---
gnu/local.mk | 1 +
gnu/services/configuration.scm | 205 +++++++++++++++++++++++++++++++++++++++++
gnu/services/cups.scm | 180 +++---------------------------------
gnu/services/mail.scm | 183 +++---------------------------------
4 files changed, 233 insertions(+), 336 deletions(-)
create mode 100644 gnu/services/configuration.scm
diff --git a/gnu/local.mk b/gnu/local.mk
index 4913727..03f4ad4 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -400,6 +400,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 \
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
new file mode 100644
index 0000000..ed9285f
--- /dev/null
+++ b/gnu/services/configuration.scm
@@ -0,0 +1,205 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; 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)
+ #: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 (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 defining complex configurations
+;;;
+;;; 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))))
diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm
index 7542ee2..391046a 100644
--- a/gnu/services/cups.scm
+++ b/gnu/services/cups.scm
@@ -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))
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index cb0f119..4db0328 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
@@ -60,112 +56,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)
@@ -175,12 +65,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
@@ -188,9 +72,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)
@@ -271,7 +152,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")
@@ -290,7 +171,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")
@@ -309,14 +190,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)
@@ -340,7 +221,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)
@@ -350,7 +231,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},
@@ -388,7 +269,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")
@@ -1492,8 +1373,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
@@ -1629,8 +1510,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)
@@ -1655,39 +1536,5 @@ 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))
--
2.10.2
^ permalink raw reply related [flat|nested] 9+ messages in thread
* Re: [PATCH] services: Make dovecot and cups configuration abstractions available
2016-11-24 18:17 ` Julien Lepiller
@ 2016-11-26 8:49 ` John Darrington
2016-11-26 18:37 ` Ludovic Courtès
2016-11-26 18:43 ` Ludovic Courtès
1 sibling, 1 reply; 9+ messages in thread
From: John Darrington @ 2016-11-26 8:49 UTC (permalink / raw)
To: Julien Lepiller; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 893 bytes --]
On Thu, Nov 24, 2016 at 07:17:42PM +0100, Julien Lepiller wrote:
+(define (serialize-string field-name val)
+ (serialize-field field-name val))
I find it useful to allow such fields to take the value #f and meaning
that they will be ignored by their respective serialize- procedures.
For example:
(define (serialize-string field-name val)
(if val
(serialize-field field-name val)))
+(define (serialize-boolean field-name val)
+ (serialize-string field-name (if val "yes" "no")))
Some configs require "true" and "false" instead of "yes" and "no". So perhaps
this can be generalised a little.
J'
--
Avoid eavesdropping. Send strong encrypted email.
PGP Public key ID: 1024D/2DE827B3
fingerprint = 8797 A26D 0854 2EAB 0285 A290 8A67 719C 2DE8 27B3
See http://sks-keyservers.net or any PGP keyserver for public key.
[-- Attachment #2: Digital signature --]
[-- Type: application/pgp-signature, Size: 181 bytes --]
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] services: Make dovecot and cups configuration abstractions available
2016-11-26 8:49 ` John Darrington
@ 2016-11-26 18:37 ` Ludovic Courtès
0 siblings, 0 replies; 9+ messages in thread
From: Ludovic Courtès @ 2016-11-26 18:37 UTC (permalink / raw)
To: John Darrington; +Cc: guix-devel
John Darrington <john@darrington.wattle.id.au> skribis:
> On Thu, Nov 24, 2016 at 07:17:42PM +0100, Julien Lepiller wrote:
>
>
> +(define (serialize-string field-name val)
> + (serialize-field field-name val))
>
> I find it useful to allow such fields to take the value #f and meaning
> that they will be ignored by their respective serialize- procedures.
> For example:
> (define (serialize-string field-name val)
> (if val
> (serialize-field field-name val)))
>
> +(define (serialize-boolean field-name val)
> + (serialize-string field-name (if val "yes" "no")))
>
> Some configs require "true" and "false" instead of "yes" and "no". So perhaps
> this can be generalised a little.
Probably, but this patch is just about moving code around. :-)
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] services: Make dovecot and cups configuration abstractions available
2016-11-24 18:17 ` Julien Lepiller
2016-11-26 8:49 ` John Darrington
@ 2016-11-26 18:43 ` Ludovic Courtès
1 sibling, 0 replies; 9+ messages in thread
From: Ludovic Courtès @ 2016-11-26 18:43 UTC (permalink / raw)
To: Julien Lepiller; +Cc: guix-devel
Julien Lepiller <julien@lepiller.eu> skribis:
> From 1b60fac10caa9ab05cf169206004f46b46f2db40 Mon Sep 17 00:00:00 2001
> From: Julien Lepiller <julien@lepiller.eu>
> Date: Wed, 23 Nov 2016 21:43:42 +0100
> Subject: [PATCH] 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.
Applied.
I changed the copyright line back to Andy, since he wrote this, and
added #:autoload instead of #:use-module for the Texinfo modules.
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2016-11-26 18:43 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2016-11-20 17:07 [PATCH] services: Make dovecot and cups configuration abstractions available Julien Lepiller
2016-11-22 22:49 ` Ludovic Courtès
2016-11-23 21:08 ` Julien Lepiller
2016-11-23 21:46 ` Clément Lassieur
2016-11-24 13:25 ` Ludovic Courtès
2016-11-24 18:17 ` Julien Lepiller
2016-11-26 8:49 ` John Darrington
2016-11-26 18:37 ` Ludovic Courtès
2016-11-26 18:43 ` Ludovic Courtès
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).