summaryrefslogtreecommitdiff
path: root/gnu/services/configuration.scm
diff options
context:
space:
mode:
authorJulien Lepiller <julien@lepiller.eu>2016-11-23 21:43:42 +0100
committerLudovic Courtès <ludo@gnu.org>2016-11-26 19:46:01 +0100
commit5305ed20027a32ff1221cac6a131849852e807ba (patch)
tree6f813f4a070cdecaa3ef35f0690c952c04ca8d8a /gnu/services/configuration.scm
parentcf3678df6e1bdbb4bf80d2fae041be69eec2cd67 (diff)
downloadpatches-5305ed20027a32ff1221cac6a131849852e807ba.tar
patches-5305ed20027a32ff1221cac6a131849852e807ba.tar.gz
services: Factorize configuration abstraction.
* gnu/services/mail.scm and gnu/services/cups.scm (&configuration-error) (configuration-error, configuration-field-error) (configuration-missing-field, configuration-field, serialize-configuration) (validate-configuration, define-configuration, uglify-field-name) (serialize-field, serialize-package, serialize-string) (serialize-space-separated-string-list, space-separated-string-list?) (serialize-file-name, file-name?, serialize-field-name) (generate-documentation): Move duplicate code... * gnu/services/configuration.scm: ...to this new file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add configuration.scm. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Diffstat (limited to 'gnu/services/configuration.scm')
-rw-r--r--gnu/services/configuration.scm205
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))))