| 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)))) |