>From 9acc9456f4e61506105bc109298aedb66e31efd0 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <address@hidden>
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 address@hidden 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 address@hidden 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