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