* [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).