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>
6 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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
43 validate-configuration
44 generate-documentation
49 ;;; Syntax for creating Scheme bindings to complex configuration files.
53 (define-condition-type &configuration-error &error
56 (define (configuration-error message)
57 (raise (condition (&message (message message))
58 (&configuration-error))))
59 (define (configuration-field-error field val)
61 (format #f "Invalid value for field ~a: ~s" field val)))
62 (define (configuration-missing-field kind field)
64 (format #f "~a configuration missing required field ~a" kind field)))
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))
76 (define (serialize-configuration config fields)
78 #$@(map (lambda (field)
79 ((configuration-field-serializer field)
80 (configuration-field-name field)
81 ((configuration-field-getter field) config)))
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))))
92 (define-syntax-rule (id ctx parts ...)
93 "Assemble PARTS into a raw (unhygienic) identifier."
94 (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
96 (define-syntax define-maybe
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)))
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) ""))))))))
111 (define-syntax define-configuration
114 ((_ stem (field (field-type def) doc) ...)
115 (with-syntax (((field-getter ...)
117 (id #'stem #'stem #'- field))
119 ((field-predicate ...)
121 (id #'stem type #'?))
123 ((field-serializer ...)
125 (id #'stem #'serialize- type))
126 #'(field-type ...))))
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))
134 (define #,(id #'stem #'stem #'-fields)
135 (list (configuration-field
138 (getter field-getter)
139 (predicate field-predicate)
140 (serializer field-serializer)
141 (default-value-thunk (lambda () def))
144 (define-syntax-rule (stem arg (... ...))
145 (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
146 (validate-configuration conf
147 #,(id #'stem #'stem #'-fields))
150 (define (serialize-package field-name val)
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:")
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))))
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)))
178 ,@(if (show-default? default)
179 `((para "Defaults to " (samp ,(str default)) "."))
183 (or (assq-ref sub-documentation field-name) '())))))
185 (stexi->texi `(*fragment* . ,(generate documentation-name))))