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 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu services configuration)
  22   #:use-module (guix packages)
  23   #:use-module (guix records)
  24   #:use-module (guix gexp)
  25   #:autoload   (texinfo) (texi-fragment->stexi)
  26   #:autoload   (texinfo serialize) (stexi->texi)
  27   #:use-module (ice-9 match)
  28   #:use-module ((srfi srfi-1) #:select (append-map))
  29   #:use-module (srfi srfi-34)
  30   #:use-module (srfi srfi-35)
  31   #:export (configuration-field
  32             configuration-field-name
  33             configuration-field-type
  34             configuration-missing-field
  35             configuration-field-error
  36             configuration-field-serializer
  37             configuration-field-getter
  38             configuration-field-default-value-thunk
  39             configuration-field-documentation
  40             serialize-configuration
  41             define-maybe
  42             define-configuration
  43             validate-configuration
  44             generate-documentation
  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   #~(string-append
  78      #$@(map (lambda (field)
  79                ((configuration-field-serializer field)
  80                 (configuration-field-name field)
  81                 ((configuration-field-getter field) config)))
  82              fields)))
  83
  84 (define (validate-configuration config fields)
  85   (for-each (lambda (field)
  86               (let ((val ((configuration-field-getter field) config)))
  87                 (unless ((configuration-field-predicate field) val)
  88                   (configuration-field-error
  89                    (configuration-field-name field) val))))
  90             fields))
  91
  92 (define-syntax-rule (id ctx parts ...)
  93   "Assemble PARTS into a raw (unhygienic)  identifier."
  94   (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
  95
  96 (define-syntax define-maybe
  97   (lambda (x)
  98     (syntax-case x ()
  99       ((_ stem)
 100        (with-syntax
 101            ((stem?                (id #'stem #'stem #'?))
 102             (maybe-stem?          (id #'stem #'maybe- #'stem #'?))
 103             (serialize-stem       (id #'stem #'serialize- #'stem))
 104             (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
 105          #'(begin
 106              (define (maybe-stem? val)
 107                (or (eq? val 'disabled) (stem? val)))
 108              (define (serialize-maybe-stem field-name val)
 109                (if (stem? val) (serialize-stem field-name val) ""))))))))
 110
 111 (define-syntax define-configuration
 112   (lambda (stx)
 113     (syntax-case stx ()
 114       ((_ stem (field (field-type def) doc) ...)
 115        (with-syntax (((field-getter ...)
 116                       (map (lambda (field)
 117                              (id #'stem #'stem #'- field))
 118                            #'(field ...)))
 119                      ((field-predicate ...)
 120                       (map (lambda (type)
 121                              (id #'stem type #'?))
 122                            #'(field-type ...)))
 123                      ((field-serializer ...)
 124                       (map (lambda (type)
 125                              (id #'stem #'serialize- type))
 126                            #'(field-type ...))))
 127            #`(begin
 128                (define-record-type* #,(id #'stem #'< #'stem #'>)
 129                  #,(id #'stem #'% #'stem)
 130                  #,(id #'stem #'make- #'stem)
 131                  #,(id #'stem #'stem #'?)
 132                  (field field-getter (default def))
 133                  ...)
 134                (define #,(id #'stem #'stem #'-fields)
 135                  (list (configuration-field
 136                         (name 'field)
 137                         (type 'field-type)
 138                         (getter field-getter)
 139                         (predicate field-predicate)
 140                         (serializer field-serializer)
 141                         (default-value-thunk (lambda () def))
 142                         (documentation doc))
 143                        ...))
 144                (define-syntax-rule (stem arg (... ...))
 145                  (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
 146                    (validate-configuration conf
 147                                            #,(id #'stem #'stem #'-fields))
 148                    conf))))))))
 149
 150 (define (serialize-package field-name val)
 151   "")
 152
 153 ;; A little helper to make it easier to document all those fields.
 154 (define (generate-documentation documentation documentation-name)
 155   (define (str x) (object->string x))
 156   (define (generate configuration-name)
 157     (match (assq-ref documentation configuration-name)
 158       ((fields . sub-documentation)
 159        `((para "Available " (code ,(str configuration-name)) " fields are:")
 160          ,@(map
 161             (lambda (f)
 162               (let ((field-name (configuration-field-name f))
 163                     (field-type (configuration-field-type f))
 164                     (field-docs (cdr (texi-fragment->stexi
 165                                       (configuration-field-documentation f))))
 166                     (default (catch #t
 167                                (configuration-field-default-value-thunk f)
 168                                (lambda _ '%invalid))))
 169                 (define (show-default? val)
 170                   (or (string? val) (number? val) (boolean? val)
 171                       (and (symbol? val) (not (eq? val '%invalid)))
 172                       (and (list? val) (and-map show-default? val))))
 173                 `(deftypevr (% (category
 174                                 (code ,(str configuration-name)) " parameter")
 175                                (data-type ,(str field-type))
 176                                (name ,(str field-name)))
 177                    ,@field-docs
 178                    ,@(if (show-default? default)
 179                          `((para "Defaults to " (samp ,(str default)) "."))
 180                          '())
 181                    ,@(append-map
 182                       generate
 183                       (or (assq-ref sub-documentation field-name) '())))))
 184             fields)))))
 185   (stexi->texi `(*fragment* . ,(generate documentation-name))))