gnu/services/configuration.scm

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