gnu/services/configuration.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu services configuration)
  20   #:use-module (guix packages)
  21   #:use-module (guix records)
  22   #:use-module (guix gexp)
  23   #:autoload   (texinfo) (texi-fragment->stexi)
  24   #:autoload   (texinfo serialize) (stexi->texi)
  25   #:use-module (ice-9 match)
  26   #:use-module ((srfi srfi-1) #:select (append-map))
  27   #:use-module (srfi srfi-34)
  28   #:use-module (srfi srfi-35)
  29   #:export (configuration-field
  30             configuration-field-name
  31             configuration-field-type
  32             configuration-missing-field
  33             configuration-field-error
  34             configuration-field-serializer
  35             configuration-field-getter
  36             configuration-field-default-value-thunk
  37             configuration-field-documentation
  38             serialize-configuration
  39             define-configuration
  40             validate-configuration
  41             generate-documentation
  42             serialize-package))
  43
  44 ;;; Commentary:
  45 ;;;
  46 ;;; Syntax for creating Scheme bindings to complex configuration files.
  47 ;;;
  48 ;;; Code:
  49
  50 (define-condition-type &configuration-error &error
  51   configuration-error?)
  52
  53 (define (configuration-error message)
  54   (raise (condition (&message (message message))
  55                     (&configuration-error))))
  56 (define (configuration-field-error field val)
  57   (configuration-error
  58    (format #f "Invalid value for field ~a: ~s" field val)))
  59 (define (configuration-missing-field kind field)
  60   (configuration-error
  61    (format #f "~a configuration missing required field ~a" kind field)))
  62
  63 (define-record-type* <configuration-field>
  64   configuration-field make-configuration-field configuration-field?
  65   (name configuration-field-name)
  66   (type configuration-field-type)
  67   (getter configuration-field-getter)
  68   (predicate configuration-field-predicate)
  69   (serializer configuration-field-serializer)
  70   (default-value-thunk configuration-field-default-value-thunk)
  71   (documentation configuration-field-documentation))
  72
  73 (define (serialize-configuration config fields)
  74   (for-each (lambda (field)
  75               ((configuration-field-serializer field)
  76                (configuration-field-name field)
  77                ((configuration-field-getter field) config)))
  78             fields))
  79
  80 (define (validate-configuration config fields)
  81   (for-each (lambda (field)
  82               (let ((val ((configuration-field-getter field) config)))
  83                 (unless ((configuration-field-predicate field) val)
  84                   (configuration-field-error
  85                    (configuration-field-name field) val))))
  86             fields))
  87
  88 (define-syntax define-configuration
  89   (lambda (stx)
  90     (define (id ctx part . parts)
  91       (let ((part (syntax->datum part)))
  92         (datum->syntax
  93          ctx
  94          (match parts
  95            (() part)
  96            (parts (symbol-append part
  97                                  (syntax->datum (apply id ctx parts))))))))
  98     (syntax-case stx ()
  99       ((_ stem (field (field-type def) doc) ...)
 100        (with-syntax (((field-getter ...)
 101                       (map (lambda (field)
 102                              (id #'stem #'stem #'- field))
 103                            #'(field ...)))
 104                      ((field-predicate ...)
 105                       (map (lambda (type)
 106                              (id #'stem type #'?))
 107                            #'(field-type ...)))
 108                      ((field-serializer ...)
 109                       (map (lambda (type)
 110                              (id #'stem #'serialize- type))
 111                            #'(field-type ...))))
 112            #`(begin
 113                (define-record-type* #,(id #'stem #'< #'stem #'>)
 114                  #,(id #'stem #'% #'stem)
 115                  #,(id #'stem #'make- #'stem)
 116                  #,(id #'stem #'stem #'?)
 117                  (field field-getter (default def))
 118                  ...)
 119                (define #,(id #'stem #'stem #'-fields)
 120                  (list (configuration-field
 121                         (name 'field)
 122                         (type 'field-type)
 123                         (getter field-getter)
 124                         (predicate field-predicate)
 125                         (serializer field-serializer)
 126                         (default-value-thunk (lambda () def))
 127                         (documentation doc))
 128                        ...))
 129                (define-syntax-rule (stem arg (... ...))
 130                  (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
 131                    (validate-configuration conf
 132                                            #,(id #'stem #'stem #'-fields))
 133                    conf))))))))
 134
 135 (define (serialize-package field-name val)
 136   #f)
 137
 138 ;; A little helper to make it easier to document all those fields.
 139 (define (generate-documentation documentation documentation-name)
 140   (define (str x) (object->string x))
 141   (define (generate configuration-name)
 142     (match (assq-ref documentation configuration-name)
 143       ((fields . sub-documentation)
 144        `((para "Available " (code ,(str configuration-name)) " fields are:")
 145          ,@(map
 146             (lambda (f)
 147               (let ((field-name (configuration-field-name f))
 148                     (field-type (configuration-field-type f))
 149                     (field-docs (cdr (texi-fragment->stexi
 150                                       (configuration-field-documentation f))))
 151                     (default (catch #t
 152                                (configuration-field-default-value-thunk f)
 153                                (lambda _ '%invalid))))
 154                 (define (show-default? val)
 155                   (or (string? default) (number? default) (boolean? default)
 156                       (and (symbol? val) (not (eq? val '%invalid)))
 157                       (and (list? val) (and-map show-default? val))))
 158                 `(deftypevr (% (category
 159                                 (code ,(str configuration-name)) " parameter")
 160                                (data-type ,(str field-type))
 161                                (name ,(str field-name)))
 162                    ,@field-docs
 163                    ,@(if (show-default? default)
 164                          `((para "Defaults to " (samp ,(str default)) "."))
 165                          '())
 166                    ,@(append-map
 167                       generate
 168                       (or (assq-ref sub-documentation field-name) '())))))
 169             fields)))))
 170   (stexi->texi `(*fragment* . ,(generate documentation-name))))