projects/guix·blob ruby-team · refs

590 lines · 23.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015 Andy Wingo <[email protected]>
3;;; Copyright © 2017 Mathieu Othacehe <[email protected]>
4;;; Copyright © 2017, 2018 Clément Lassieur <[email protected]>
5;;; Copyright © 2021 Xinglu Chen <[email protected]>
6;;; Copyright © 2021, 2022 Maxim Cournoyer <[email protected]>
7;;; Copyright © 2021 Andrew Tropin <[email protected]>
8;;; Copyright © 2022 Maxime Devos <[email protected]>
9;;; Copyright © 2023 Bruno Victal <[email protected]>
10;;; Copyright © 2024 Herman Rimm <[email protected]>
11;;;
12;;; This file is part of GNU Guix.
13;;;
14;;; GNU Guix is free software; you can redistribute it and/or modify it
15;;; under the terms of the GNU General Public License as published by
16;;; the Free Software Foundation; either version 3 of the License, or (at
17;;; your option) any later version.
18;;;
19;;; GNU Guix is distributed in the hope that it will be useful, but
20;;; WITHOUT ANY WARRANTY; without even the implied warranty of
21;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22;;; GNU General Public License for more details.
23;;;
24;;; You should have received a copy of the GNU General Public License
25;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
26
27(define-module (gnu services configuration)
28 #:use-module (guix packages)
29 #:use-module (guix records)
30 #:use-module (guix gexp)
31 #:use-module ((guix utils) #:select (source-properties->location))
32 #:use-module ((guix diagnostics)
33 #:select (formatted-message location-file &error-location
34 warning))
35 #:use-module ((guix modules) #:select (file-name->module-name))
36 #:use-module (guix i18n)
37 #:autoload (texinfo) (texi-fragment->stexi)
38 #:autoload (texinfo serialize) (stexi->texi)
39 #:use-module (ice-9 curried-definitions)
40 #:use-module (ice-9 format)
41 #:use-module (ice-9 match)
42 #:use-module (srfi srfi-1)
43 #:use-module (srfi srfi-26)
44 #:use-module (srfi srfi-34)
45 #:use-module (srfi srfi-35)
46 #:use-module (srfi srfi-171)
47 #:export (configuration-field
48 configuration-field-name
49 configuration-field-type
50 configuration-missing-field
51 configuration-field-error
52 configuration-field-sanitizer
53 configuration-field-serializer
54 configuration-field-getter
55 configuration-field-default-value-thunk
56 configuration-field-documentation
57
58 configuration-error?
59
60 define-configuration
61 define-configuration/no-serialization
62 no-serialization
63
64 empty-serializer?
65 tfilter-maybe-value
66 base-transducer
67
68 serialize-configuration
69 define-maybe
70 define-maybe/no-serialization
71 %unset-value
72 maybe-value
73 maybe-value-set?
74 generate-documentation
75 configuration->documentation
76 empty-serializer
77 serialize-package
78 define-enumerated-field-type
79
80 filter-configuration-fields
81
82 interpose
83 list-of
84
85 list-of-packages?
86 list-of-strings?
87 list-of-symbols?
88 alist?
89 serialize-file-like
90 text-config?
91 serialize-text-config
92 generic-serialize-alist-entry
93 generic-serialize-alist))
94
95;;; Commentary:
96;;;
97;;; Syntax for creating Scheme bindings to complex configuration files.
98;;;
99;;; Code:
100
101(define-condition-type &configuration-error &error
102 configuration-error?)
103
104(define (configuration-error message)
105 (raise (condition (&message (message message))
106 (&configuration-error))))
107(define (configuration-field-error loc field value)
108 (raise (apply
109 make-compound-condition
110 (formatted-message (G_ "invalid value ~s for field '~a'")
111 value field)
112 (condition (&configuration-error))
113 (if loc
114 (list (condition
115 (&error-location (location loc))))
116 '()))))
117
118(define (configuration-missing-field kind field)
119 (configuration-error
120 (format #f "~a configuration missing required field ~a" kind field)))
121(define (configuration-missing-default-value kind field)
122 (configuration-error
123 (format #f "The field `~a' of the `~a' configuration record \
124does not have a default value" field kind)))
125
126(define-record-type* <configuration-field>
127 configuration-field make-configuration-field configuration-field?
128 (name configuration-field-name)
129 (type configuration-field-type)
130 (getter configuration-field-getter)
131 (predicate configuration-field-predicate)
132 (sanitizer configuration-field-sanitizer)
133 (serializer configuration-field-serializer)
134 (default-value-thunk configuration-field-default-value-thunk)
135 (documentation configuration-field-documentation))
136
137(define (empty-serializer? field)
138 "Predicate that checks whether FIELD is exempt from serialization."
139 (eq? empty-serializer
140 (configuration-field-serializer field)))
141
142(define (tfilter-maybe-value config)
143 "Return a transducer for CONFIG that removes all maybe-type fields whose
144value is '%unset-marker."
145 (tfilter (lambda (field)
146 (let ((field-value ((configuration-field-getter field) config)))
147 (maybe-value-set? field-value)))))
148
149(define (base-transducer config)
150 "Return a transducer for CONFIG that calls the serializing procedures only
151for fields marked for serialization and whose values are not '%unset-marker."
152 (compose (tremove empty-serializer?)
153 ;; Only serialize fields whose value isn't '%unset-marker%.
154 (tfilter-maybe-value config)
155 (tmap (lambda (field)
156 ((configuration-field-serializer field)
157 (configuration-field-name field)
158 ((configuration-field-getter field) config))))))
159
160(define (serialize-configuration config fields)
161 "Return a G-expression that contains the values corresponding to the
162FIELDS of CONFIG, a record that has been generated by `define-configuration'.
163The G-expression can then be serialized to disk by using something like
164`mixed-text-file'."
165 #~(string-append
166 #$@(list-transduce (base-transducer config) rcons fields)))
167
168(define-syntax-rule (id ctx parts ...)
169 "Assemble PARTS into a raw (unhygienic) identifier."
170 (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
171
172(define (define-maybe-helper serialize? prefix syn)
173 (syntax-case syn ()
174 ((_ stem)
175 (with-syntax
176 ((stem? (id #'stem #'stem #'?))
177 (maybe-stem? (id #'stem #'maybe- #'stem #'?))
178 (serialize-stem (if prefix
179 (id #'stem prefix #'serialize- #'stem)
180 (id #'stem #'serialize- #'stem)))
181 (serialize-maybe-stem (if prefix
182 (id #'stem prefix #'serialize-maybe- #'stem)
183 (id #'stem #'serialize-maybe- #'stem))))
184 #`(begin
185 (define (maybe-stem? val)
186 (or (not (maybe-value-set? val))
187 (stem? val)))
188 #,@(if serialize?
189 (list #'(define (serialize-maybe-stem field-name val)
190 (if (stem? val)
191 (serialize-stem field-name val)
192 "")))
193 '()))))))
194
195(define-syntax define-maybe
196 (lambda (x)
197 (syntax-case x (no-serialization prefix)
198 ((_ stem (no-serialization))
199 (define-maybe-helper #f #f #'(_ stem)))
200 ((_ stem (prefix serializer-prefix))
201 (define-maybe-helper #t #'serializer-prefix #'(_ stem)))
202 ((_ stem)
203 (define-maybe-helper #t #f #'(_ stem))))))
204
205(define-syntax-rule (define-maybe/no-serialization stem)
206 (define-maybe stem (no-serialization)))
207
208(define (normalize-field-type+def s)
209 (syntax-case s ()
210 ((field-type def)
211 (identifier? #'field-type)
212 (values #'(field-type def)))
213 ((field-type)
214 (identifier? #'field-type)
215 (values #'(field-type %unset-value)))
216 (field-type
217 (identifier? #'field-type)
218 (values #'(field-type %unset-value)))))
219
220(define (define-configuration-helper serialize? serializer-prefix syn)
221
222 (define (normalize-extra-args s)
223 "Extract and normalize arguments following @var{doc}."
224 (let loop ((s s)
225 (sanitizer* #f)
226 (serializer* #f))
227 (syntax-case s (sanitizer serializer empty-serializer)
228 (((sanitizer proc) tail ...)
229 (if sanitizer*
230 (syntax-violation 'sanitizer
231 "duplicate entry" #'proc)
232 (loop #'(tail ...) #'proc serializer*)))
233 (((serializer proc) tail ...)
234 (if serializer*
235 (syntax-violation 'serializer
236 "duplicate or conflicting entry" #'proc)
237 (loop #'(tail ...) sanitizer* #'proc)))
238 ((empty-serializer tail ...)
239 (if serializer*
240 (syntax-violation 'empty-serializer
241 "duplicate or conflicting entry" #f)
242 (loop #'(tail ...) sanitizer* #'empty-serializer)))
243 (() ; stop condition
244 (values (list sanitizer* serializer*)))
245 ((proc) ; TODO: deprecated, to be removed.
246 (not (or sanitizer* serializer*))
247 (begin
248 (warning #f (G_ "specifying serializers after documentation is \
249deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
250 (values (list #f #'proc)))))))
251
252 (syntax-case syn ()
253 ((_ stem (field field-type+def doc extra-args ...) ...)
254 (with-syntax
255 ((((field-type def) ...)
256 (map normalize-field-type+def #'(field-type+def ...)))
257 (((sanitizer* serializer*) ...)
258 (map normalize-extra-args #'((extra-args ...) ...))))
259 (with-syntax
260 (((field-getter ...)
261 (map (lambda (field)
262 (id #'stem #'stem #'- field))
263 #'(field ...)))
264 ((field-predicate ...)
265 (map (lambda (type)
266 (id #'stem type #'?))
267 #'(field-type ...)))
268 ((field-default ...)
269 (map (match-lambda
270 ((field-type default-value)
271 default-value))
272 #'((field-type def) ...)))
273 ((field-sanitizer ...)
274 #'(sanitizer* ...))
275 ((field-serializer ...)
276 (map (lambda (type proc)
277 (and serialize?
278 (or proc
279 (if serializer-prefix
280 (id #'stem serializer-prefix #'serialize- type)
281 (id #'stem #'serialize- type)))))
282 #'(field-type ...)
283 #'(serializer* ...))))
284 (define (default-field-sanitizer name pred)
285 ;; Define a macro for use as a record field sanitizer, where NAME
286 ;; is the name of the field and PRED is the predicate that tells
287 ;; whether a value is valid for this field.
288 #`(define-syntax #,(id #'stem #'validate- #'stem #'- name)
289 (lambda (s)
290 ;; Make sure the given VALUE, for field NAME, passes PRED.
291 (syntax-case s ()
292 ((_ value)
293 (with-syntax ((name #'#,name)
294 (pred #'#,pred)
295 (loc (datum->syntax #'value
296 (syntax-source #'value))))
297 #'(if (pred value)
298 value
299 (configuration-field-error
300 (and=> 'loc source-properties->location)
301 'name value))))))))
302
303 #`(begin
304 ;; Define field validation macros.
305 #,@(filter-map (lambda (name pred sanitizer)
306 (if sanitizer
307 #f
308 (default-field-sanitizer name pred)))
309 #'(field ...)
310 #'(field-predicate ...)
311 #'(field-sanitizer ...))
312
313 (define-record-type* #,(id #'stem #'< #'stem #'>)
314 stem
315 #,(id #'stem #'make- #'stem)
316 #,(id #'stem #'stem #'?)
317 #,@(map (lambda (name getter def sanitizer)
318 #`(#,name #,getter
319 (default #,def)
320 (sanitize
321 #,(or sanitizer
322 (id #'stem
323 #'validate- #'stem #'- name)))))
324 #'(field ...)
325 #'(field-getter ...)
326 #'(field-default ...)
327 #'(field-sanitizer ...))
328 (%location #,(id #'stem #'stem #'-source-location)
329 (default (and=> (current-source-location)
330 source-properties->location))
331 (innate)))
332
333 (define #,(id #'stem #'stem #'-fields)
334 (list (configuration-field
335 (name 'field)
336 (type 'field-type)
337 (getter field-getter)
338 (predicate field-predicate)
339 (sanitizer
340 (or field-sanitizer
341 (id #'stem #'validate- #'stem #'- #'field)))
342 (serializer field-serializer)
343 (default-value-thunk
344 (lambda ()
345 (if (maybe-value-set? (syntax->datum field-default))
346 field-default
347 (configuration-missing-default-value
348 '#,(id #'stem #'% #'stem) 'field))))
349 (documentation doc))
350 ...))))))))
351
352(define no-serialization ;syntactic keyword for 'define-configuration'
353 '(no serialization))
354
355(define-syntax define-configuration
356 (lambda (s)
357 (syntax-case s (no-serialization prefix)
358 ((_ stem (field field-type+def doc custom-serializer ...) ...
359 (no-serialization))
360 (define-configuration-helper
361 #f #f #'(_ stem (field field-type+def doc custom-serializer ...)
362 ...)))
363 ((_ stem (field field-type+def doc custom-serializer ...) ...
364 (prefix serializer-prefix))
365 (define-configuration-helper
366 #t #'serializer-prefix #'(_ stem (field field-type+def
367 doc custom-serializer ...)
368 ...)))
369 ((_ stem (field field-type+def doc custom-serializer ...) ...)
370 (define-configuration-helper
371 #t #f #'(_ stem (field field-type+def doc custom-serializer ...)
372 ...))))))
373
374(define-syntax-rule (define-configuration/no-serialization
375 stem (field field-type+def
376 doc custom-serializer ...) ...)
377 (define-configuration stem (field field-type+def
378 doc custom-serializer ...) ...
379 (no-serialization)))
380
381(define (empty-serializer field-name val) "")
382(define serialize-package empty-serializer)
383
384;; Ideally this should be an implementation detail, but we export it
385;; to provide a simpler API that enables unsetting a configuration
386;; field that has a maybe type, but also a default value. We give it
387;; a value that sticks out to the reader when something goes wrong.
388;;
389;; An example use-case would be something like a network application
390;; that uses a default port, but the field can explicitly be unset to
391;; request a random port at startup.
392(define %unset-value '%unset-marker%)
393
394(define (maybe-value-set? value)
395 "Predicate to check whether a 'maybe' value was explicitly provided."
396 (not (eq? %unset-value value)))
397
398;; Ideally there should be a compiler macro for this predicate, that expands
399;; to a conditional that only instantiates the default value when needed.
400(define* (maybe-value value #:optional (default #f))
401 "Returns VALUE, unless it is the unset value, in which case it returns
402DEFAULT."
403 (if (maybe-value-set? value)
404 value
405 default))
406
407;; A little helper to make it easier to document all those fields.
408(define (generate-documentation documentation documentation-name)
409 (define (str x) (object->string x))
410
411 (define (package->symbol package)
412 "Return the first symbol name of a package that matches PACKAGE, else #f."
413 (let* ((module (file-name->module-name
414 (location-file (package-location package))))
415 (symbols (filter-map
416 identity
417 (module-map (lambda (symbol var)
418 (and (equal? package (variable-ref var))
419 symbol))
420 (resolve-module module)))))
421 (if (null? symbols)
422 #f
423 (first symbols))))
424
425 (define (generate configuration-name)
426 (match (assq-ref documentation configuration-name)
427 ((fields . sub-documentation)
428 `((deftp (% (category "Data Type") (name ,(str configuration-name)))
429 (para "Available " (code ,(str configuration-name)) " fields are:")
430 (table
431 (% (formatter (asis)))
432 ,@(map
433 (lambda (f)
434 (let ((field-name (configuration-field-name f))
435 (field-type (configuration-field-type f))
436 (field-docs (cdr (texi-fragment->stexi
437 (configuration-field-documentation f))))
438 (default (catch #t
439 (configuration-field-default-value-thunk f)
440 (lambda _ '%invalid))))
441 (define (show-default? val)
442 (or (string? val) (number? val) (boolean? val)
443 (package? val)
444 (and (symbol? val) (not (eq? val '%invalid)))
445 (and (list? val) (and-map show-default? val))))
446
447 (define (show-default val)
448 (cond
449 ((package? val)
450 (symbol->string (package->symbol val)))
451 (((list-of package?) val)
452 (format #f "(~{~a~^ ~})" (map package->symbol val)))
453 (else (str val))))
454
455 `(entry (% (heading
456 (code ,(str field-name))
457 ,@(if (show-default? default)
458 `(" (default: "
459 (code ,(show-default default)) ")")
460 '())
461 " (type: " ,(str field-type) ")"))
462 (para ,@field-docs)
463 ,@(append-map
464 generate
465 (filter-map
466 (match-lambda
467 ((name config)
468 (and (eq? name field-name)
469 config)))
470 sub-documentation)))))
471 fields)))))))
472 (stexi->texi `(*fragment* . ,(generate documentation-name))))
473
474(define (configuration->documentation configuration-symbol)
475 "Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when
476defining a configuration record with DEFINE-CONFIGURATION, and output the
477Texinfo documentation of its fields."
478 ;; This is helper for a simple, straight-forward application of
479 ;; GENERATE-DOCUMENTATION.
480 (let ((fields-getter (module-ref (current-module)
481 (symbol-append configuration-symbol
482 '-fields))))
483 (display (generate-documentation `((,configuration-symbol ,fields-getter))
484 configuration-symbol))))
485
486(define* (filter-configuration-fields configuration-fields fields
487 #:optional negate?)
488 "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS.
489If NEGATE? is @code{#t}, retrieve all fields except FIELDS."
490 (filter (lambda (field)
491 (let ((member? (member (configuration-field-name field) fields)))
492 (if (not negate?) member? (not member?))))
493 configuration-fields))
494
495
496(define* (interpose ls #:optional (delimiter "\n") (grammar 'infix))
497 "Same as @code{string-join}, but without join and string, returns a
498DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values."
499 (when (not (member grammar '(infix suffix)))
500 (raise
501 (formatted-message
502 (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.")
503 grammar)))
504 (fold-right (lambda (e acc)
505 (cons e
506 (if (and (null? acc) (eq? grammar 'infix))
507 acc
508 (cons delimiter acc))))
509 '() ls))
510
511(define-syntax define-enumerated-field-type
512 (lambda (x)
513 (syntax-case x (prefix)
514 ((_ name (option ...) (prefix serializer-prefix))
515 #`(begin
516 (define (#,(id #'name #'name #'?) x)
517 (memq x '(option ...)))
518 (define (#,(id #'name #'serializer-prefix #'serialize- #'name) field-name val)
519 (#,(id #'name #'serializer-prefix #'serialize-field) field-name val))))
520
521 ((_ name (option ...))
522 #`(define-enumerated-field-type name (option ...) (prefix #{}#))))))
523
524
525;;;
526;;; Commonly used predicates
527;;;
528
529(define (list-of pred?)
530 "Return a procedure that takes a list and check if all the elements of
531the list result in @code{#t} when applying PRED? on them."
532 (lambda (x)
533 (if (list? x)
534 (every pred? x)
535 #f)))
536
537(define list-of-packages?
538 (list-of (match-lambda
539 ((? package? pkg) #t)
540 (((? package? pkg) output) #t)
541 (_ #f))))
542
543(define list-of-strings?
544 (list-of string?))
545
546(define list-of-symbols?
547 (list-of symbol?))
548
549
550;;;
551;;; Special serializers
552;;;
553
554(define alist?
555 (list-of pair?))
556
557(define serialize-file-like empty-serializer)
558
559(define (text-config? config)
560 (list-of file-like?))
561
562(define (serialize-text-config field-name val)
563 #~(string-append
564 #$@(interpose
565 (map
566 (lambda (e)
567 #~(begin
568 (use-modules (ice-9 rdelim))
569 (with-fluids ((%default-port-encoding "UTF-8"))
570 (with-input-from-file #$e read-string))))
571 val)
572 "\n" 'suffix)))
573
574(define ((generic-serialize-alist-entry serialize-field) entry)
575 "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY."
576 (match entry
577 ((field . val) (serialize-field field val))))
578
579(define (generic-serialize-alist combine serialize-field fields)
580 "Generate a configuration from an association list FIELDS.
581
582SERIALIZE-FIELD is a procedure that takes two arguments, it will be
583applied on the fields and values of FIELDS using the
584@code{generic-serialize-alist-entry} procedure.
585
586COMBINE is a procedure that takes one or more arguments and combines
587all the alist entries into one value, @code{string-append} or
588@code{append} are usually good candidates for this."
589 (apply combine
590 (map (generic-serialize-alist-entry serialize-field) fields)))