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-missing-field
  32             configuration-field-error
  33             serialize-configuration
  34             define-configuration
  35             validate-configuration
  36             generate-documentation
  37             serialize-field
  38             serialize-string
  39             serialize-name
  40             serialize-space-separated-string-list
  41             space-separated-string-list?
  42             serialize-file-name
  43             file-name?
  44             serialize-boolean
  45             serialize-package))
  46
  47 ;;; Commentary:
  48 ;;;
  49 ;;; Syntax for creating Scheme bindings to complex configuration files.
  50 ;;;
  51 ;;; Code:
  52
  53 (define-condition-type &configuration-error &error
  54   configuration-error?)
  55
  56 (define (configuration-error message)
  57   (raise (condition (&message (message message))
  58                     (&configuration-error))))
  59 (define (configuration-field-error field val)
  60   (configuration-error
  61    (format #f "Invalid value for field ~a: ~s" field val)))
  62 (define (configuration-missing-field kind field)
  63   (configuration-error
  64    (format #f "~a configuration missing required field ~a" kind field)))
  65
  66 (define-record-type* <configuration-field>
  67   configuration-field make-configuration-field configuration-field?
  68   (name configuration-field-name)
  69   (type configuration-field-type)
  70   (getter configuration-field-getter)
  71   (predicate configuration-field-predicate)
  72   (serializer configuration-field-serializer)
  73   (default-value-thunk configuration-field-default-value-thunk)
  74   (documentation configuration-field-documentation))
  75
  76 (define (serialize-configuration config fields)
  77   (for-each (lambda (field)
  78               ((configuration-field-serializer field)
  79                (configuration-field-name field)
  80                ((configuration-field-getter field) config)))
  81             fields))
  82
  83 (define (validate-configuration config fields)
  84   (for-each (lambda (field)
  85               (let ((val ((configuration-field-getter field) config)))
  86                 (unless ((configuration-field-predicate field) val)
  87                   (configuration-field-error
  88                    (configuration-field-name field) val))))
  89             fields))
  90
  91 (define-syntax define-configuration
  92   (lambda (stx)
  93     (define (id ctx part . parts)
  94       (let ((part (syntax->datum part)))
  95         (datum->syntax
  96          ctx
  97          (match parts
  98            (() part)
  99            (parts (symbol-append part
 100                                  (syntax->datum (apply id ctx parts))))))))
 101     (syntax-case stx ()
 102       ((_ stem (field (field-type def) doc) ...)
 103        (with-syntax (((field-getter ...)
 104                       (map (lambda (field)
 105                              (id #'stem #'stem #'- field))
 106                            #'(field ...)))
 107                      ((field-predicate ...)
 108                       (map (lambda (type)
 109                              (id #'stem type #'?))
 110                            #'(field-type ...)))
 111                      ((field-serializer ...)
 112                       (map (lambda (type)
 113                              (id #'stem #'serialize- type))
 114                            #'(field-type ...))))
 115            #`(begin
 116                (define-record-type* #,(id #'stem #'< #'stem #'>)
 117                  #,(id #'stem #'% #'stem)
 118                  #,(id #'stem #'make- #'stem)
 119                  #,(id #'stem #'stem #'?)
 120                  (field field-getter (default def))
 121                  ...)
 122                (define #,(id #'stem #'stem #'-fields)
 123                  (list (configuration-field
 124                         (name 'field)
 125                         (type 'field-type)
 126                         (getter field-getter)
 127                         (predicate field-predicate)
 128                         (serializer field-serializer)
 129                         (default-value-thunk (lambda () def))
 130                         (documentation doc))
 131                        ...))
 132                (define-syntax-rule (stem arg (... ...))
 133                  (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
 134                    (validate-configuration conf
 135                                            #,(id #'stem #'stem #'-fields))
 136                    conf))))))))
 137
 138 (define (uglify-field-name field-name)
 139   (let ((str (symbol->string field-name)))
 140     (string-concatenate
 141      (map string-titlecase
 142           (string-split (if (string-suffix? "?" str)
 143                             (substring str 0 (1- (string-length str)))
 144                             str)
 145                         #\-)))))
 146
 147 (define (serialize-field field-name val)
 148   (format #t "~a ~a\n" (uglify-field-name field-name) val))
 149
 150 (define (serialize-package field-name val)
 151   #f)
 152
 153 (define (serialize-string field-name val)
 154   (serialize-field field-name val))
 155
 156 (define (space-separated-string-list? val)
 157   (and (list? val)
 158        (and-map (lambda (x)
 159                   (and (string? x) (not (string-index x #\space))))
 160                 val)))
 161 (define (serialize-space-separated-string-list field-name val)
 162   (serialize-field field-name (string-join val " ")))
 163
 164 (define (file-name? val)
 165   (and (string? val)
 166        (string-prefix? "/" val)))
 167 (define (serialize-file-name field-name val)
 168   (serialize-string field-name val))
 169
 170 (define (serialize-boolean field-name val)
 171   (serialize-string field-name (if val "yes" "no")))
 172
 173 ;; A little helper to make it easier to document all those fields.
 174 (define (generate-documentation documentation documentation-name)
 175   (define (str x) (object->string x))
 176   (define (generate configuration-name)
 177     (match (assq-ref documentation configuration-name)
 178       ((fields . sub-documentation)
 179        `((para "Available " (code ,(str configuration-name)) " fields are:")
 180          ,@(map
 181             (lambda (f)
 182               (let ((field-name (configuration-field-name f))
 183                     (field-type (configuration-field-type f))
 184                     (field-docs (cdr (texi-fragment->stexi
 185                                       (configuration-field-documentation f))))
 186                     (default (catch #t
 187                                (configuration-field-default-value-thunk f)
 188                                (lambda _ '%invalid))))
 189                 (define (show-default? val)
 190                   (or (string? default) (number? default) (boolean? default)
 191                       (and (symbol? val) (not (eq? val '%invalid)))
 192                       (and (list? val) (and-map show-default? val))))
 193                 `(deftypevr (% (category
 194                                 (code ,(str configuration-name)) " parameter")
 195                                (data-type ,(str field-type))
 196                                (name ,(str field-name)))
 197                    ,@field-docs
 198                    ,@(if (show-default? default)
 199                          `((para "Defaults to " (samp ,(str default)) "."))
 200                          '())
 201                    ,@(append-map
 202                       generate
 203                       (or (assq-ref sub-documentation field-name) '())))))
 204             fields)))))
 205   (stexi->texi `(*fragment* . ,(generate documentation-name))))