services: Factorize configuration abstraction.

* gnu/services/mail.scm and gnu/services/cups.scm (&configuration-error)
(configuration-error, configuration-field-error)
(configuration-missing-field, configuration-field, serialize-configuration)
(validate-configuration, define-configuration, uglify-field-name)
(serialize-field, serialize-package, serialize-string)
(serialize-space-separated-string-list, space-separated-string-list?)
(serialize-file-name, file-name?, serialize-field-name)
(generate-documentation): Move duplicate code...
* gnu/services/configuration.scm: ...to this new file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add configuration.scm.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

1 files changed, 205 insertions, 0 deletions

diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
new file mode 100644
index 0000000000..9f28aabc96
--- /dev/null
+++ b/gnu/services/configuration.scm
@@ -0,0 +1,205 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services configuration)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix gexp)
+  #:autoload   (texinfo) (texi-fragment->stexi)
+  #:autoload   (texinfo serialize) (stexi->texi)
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (append-map))
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:export (configuration-field
+            configuration-field-name
+            configuration-missing-field
+            configuration-field-error
+            serialize-configuration
+            define-configuration
+            validate-configuration
+            generate-documentation
+            serialize-field
+            serialize-string
+            serialize-name
+            serialize-space-separated-string-list
+            space-separated-string-list?
+            serialize-file-name
+            file-name?
+            serialize-boolean
+            serialize-package))
+
+;;; Commentary:
+;;;
+;;; Syntax for creating Scheme bindings to complex configuration files.
+;;;
+;;; Code:
+
+(define-condition-type &configuration-error &error
+  configuration-error?)
+
+(define (configuration-error message)
+  (raise (condition (&message (message message))
+                    (&configuration-error))))
+(define (configuration-field-error field val)
+  (configuration-error
+   (format #f "Invalid value for field ~a: ~s" field val)))
+(define (configuration-missing-field kind field)
+  (configuration-error
+   (format #f "~a configuration missing required field ~a" kind field)))
+
+(define-record-type* <configuration-field>
+  configuration-field make-configuration-field configuration-field?
+  (name configuration-field-name)
+  (type configuration-field-type)
+  (getter configuration-field-getter)
+  (predicate configuration-field-predicate)
+  (serializer configuration-field-serializer)
+  (default-value-thunk configuration-field-default-value-thunk)
+  (documentation configuration-field-documentation))
+
+(define (serialize-configuration config fields)
+  (for-each (lambda (field)
+              ((configuration-field-serializer field)
+               (configuration-field-name field)
+               ((configuration-field-getter field) config)))
+            fields))
+
+(define (validate-configuration config fields)
+  (for-each (lambda (field)
+              (let ((val ((configuration-field-getter field) config)))
+                (unless ((configuration-field-predicate field) val)
+                  (configuration-field-error
+                   (configuration-field-name field) val))))
+            fields))
+
+(define-syntax define-configuration
+  (lambda (stx)
+    (define (id ctx part . parts)
+      (let ((part (syntax->datum part)))
+        (datum->syntax
+         ctx
+         (match parts
+           (() part)
+           (parts (symbol-append part
+                                 (syntax->datum (apply id ctx parts))))))))
+    (syntax-case stx ()
+      ((_ stem (field (field-type def) doc) ...)
+       (with-syntax (((field-getter ...)
+                      (map (lambda (field)
+                             (id #'stem #'stem #'- field))
+                           #'(field ...)))
+                     ((field-predicate ...)
+                      (map (lambda (type)
+                             (id #'stem type #'?))
+                           #'(field-type ...)))
+                     ((field-serializer ...)
+                      (map (lambda (type)
+                             (id #'stem #'serialize- type))
+                           #'(field-type ...))))
+           #`(begin
+               (define-record-type* #,(id #'stem #'< #'stem #'>)
+                 #,(id #'stem #'% #'stem)
+                 #,(id #'stem #'make- #'stem)
+                 #,(id #'stem #'stem #'?)
+                 (field field-getter (default def))
+                 ...)
+               (define #,(id #'stem #'stem #'-fields)
+                 (list (configuration-field
+                        (name 'field)
+                        (type 'field-type)
+                        (getter field-getter)
+                        (predicate field-predicate)
+                        (serializer field-serializer)
+                        (default-value-thunk (lambda () def))
+                        (documentation doc))
+                       ...))
+               (define-syntax-rule (stem arg (... ...))
+                 (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
+                   (validate-configuration conf
+                                           #,(id #'stem #'stem #'-fields))
+                   conf))))))))
+
+(define (uglify-field-name field-name)
+  (let ((str (symbol->string field-name)))
+    (string-concatenate
+     (map string-titlecase
+          (string-split (if (string-suffix? "?" str)
+                            (substring str 0 (1- (string-length str)))
+                            str)
+                        #\-)))))
+
+(define (serialize-field field-name val)
+  (format #t "~a ~a\n" (uglify-field-name field-name) val))
+
+(define (serialize-package field-name val)
+  #f)
+
+(define (serialize-string field-name val)
+  (serialize-field field-name val))
+
+(define (space-separated-string-list? val)
+  (and (list? val)
+       (and-map (lambda (x)
+                  (and (string? x) (not (string-index x #\space))))
+                val)))
+(define (serialize-space-separated-string-list field-name val)
+  (serialize-field field-name (string-join val " ")))
+
+(define (file-name? val)
+  (and (string? val)
+       (string-prefix? "/" val)))
+(define (serialize-file-name field-name val)
+  (serialize-string field-name val))
+
+(define (serialize-boolean field-name val)
+  (serialize-string field-name (if val "yes" "no")))
+
+;; A little helper to make it easier to document all those fields.
+(define (generate-documentation documentation documentation-name)
+  (define (str x) (object->string x))
+  (define (generate configuration-name)
+    (match (assq-ref documentation configuration-name)
+      ((fields . sub-documentation)
+       `((para "Available " (code ,(str configuration-name)) " fields are:")
+         ,@(map
+            (lambda (f)
+              (let ((field-name (configuration-field-name f))
+                    (field-type (configuration-field-type f))
+                    (field-docs (cdr (texi-fragment->stexi
+                                      (configuration-field-documentation f))))
+                    (default (catch #t
+                               (configuration-field-default-value-thunk f)
+                               (lambda _ '%invalid))))
+                (define (show-default? val)
+                  (or (string? default) (number? default) (boolean? default)
+                      (and (symbol? val) (not (eq? val '%invalid)))
+                      (and (list? val) (and-map show-default? val))))
+                `(deftypevr (% (category
+                                (code ,(str configuration-name)) " parameter")
+                               (data-type ,(str field-type))
+                               (name ,(str field-name)))
+                   ,@field-docs
+                   ,@(if (show-default? default)
+                         `((para "Defaults to " (samp ,(str default)) "."))
+                         '())
+                   ,@(append-map
+                      generate
+                      (or (assq-ref sub-documentation field-name) '())))))
+            fields)))))
+  (stexi->texi `(*fragment* . ,(generate documentation-name))))