projects/guix·blob python-team · refs

594 lines · 23.5 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;;; Commentary:
28;;;
29;;; Syntax for creating Scheme bindings to complex configuration files.
30;;;
31;;; Code:
32
33(define-module (gnu services configuration)
34 #:use-module (guix packages)
35 #:use-module (guix records)
36 #:use-module (guix gexp)
37 #:use-module ((guix utils) #:select (source-properties->location))
38 #:use-module ((guix diagnostics)
39 #:select (formatted-message location-file &error-location
40 warning))
41 #:use-module ((guix modules) #:select (file-name->module-name))
42 #:use-module (guix i18n)
43 #:autoload (texinfo) (texi-fragment->stexi)
44 #:autoload (texinfo serialize) (stexi->texi)
45 #:use-module (ice-9 curried-definitions)
46 #:use-module (ice-9 format)
47 #:use-module (ice-9 match)
48 #:use-module (srfi srfi-1)
49 #:use-module (srfi srfi-26)
50 #:use-module (srfi srfi-34)
51 #:use-module (srfi srfi-35)
52 #:use-module (srfi srfi-171)
53 #:export (configuration-field
54 configuration-field-name
55 configuration-field-type
56 configuration-missing-field
57 configuration-field-error
58 configuration-field-sanitizer
59 configuration-field-serializer
60 configuration-field-getter
61 configuration-field-default-value-thunk
62 configuration-field-documentation
63
64 configuration-error?
65
66 define-configuration
67 define-configuration/no-serialization
68 no-serialization
69
70 empty-serializer?
71 tfilter-maybe-value
72 base-transducer
73
74 serialize-configuration
75 define-maybe
76 define-maybe/no-serialization
77 %unset-value
78 maybe-value
79 maybe-value-set?
80 generate-documentation
81 configuration->documentation
82 empty-serializer
83 serialize-package
84 define-enumerated-field-type
85
86 filter-configuration-fields
87
88 interpose
89 list-of
90
91 list-of-packages?
92 list-of-strings?
93 list-of-symbols?
94 alist?
95 serialize-file-like
96 text-config?
97 serialize-text-config
98 generic-serialize-alist-entry
99 generic-serialize-alist))
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 (field-value
296 (car
297 (generate-temporaries #'(value))))
298 (loc (datum->syntax #'value
299 (syntax-source #'value))))
300 #'(let ((field-value value))
301 (if (pred field-value)
302 field-value
303 (configuration-field-error
304 (and=> 'loc source-properties->location)
305 'name field-value)))))))))
306
307 #`(begin
308 ;; Define field validation macros.
309 #,@(filter-map (lambda (name pred sanitizer)
310 (if sanitizer
311 #f
312 (default-field-sanitizer name pred)))
313 #'(field ...)
314 #'(field-predicate ...)
315 #'(field-sanitizer ...))
316
317 (define-record-type* #,(id #'stem #'< #'stem #'>)
318 stem
319 #,(id #'stem #'make- #'stem)
320 #,(id #'stem #'stem #'?)
321 #,@(map (lambda (name getter def sanitizer)
322 #`(#,name #,getter
323 (default #,def)
324 (sanitize
325 #,(or sanitizer
326 (id #'stem
327 #'validate- #'stem #'- name)))))
328 #'(field ...)
329 #'(field-getter ...)
330 #'(field-default ...)
331 #'(field-sanitizer ...))
332 (%location #,(id #'stem #'stem #'-source-location)
333 (default (and=> (current-source-location)
334 source-properties->location))
335 (innate)))
336
337 (define #,(id #'stem #'stem #'-fields)
338 (list (configuration-field
339 (name 'field)
340 (type 'field-type)
341 (getter field-getter)
342 (predicate field-predicate)
343 (sanitizer
344 (or field-sanitizer
345 (id #'stem #'validate- #'stem #'- #'field)))
346 (serializer field-serializer)
347 (default-value-thunk
348 (lambda ()
349 (if (maybe-value-set? (syntax->datum field-default))
350 field-default
351 (configuration-missing-default-value
352 '#,(id #'stem #'% #'stem) 'field))))
353 (documentation doc))
354 ...))))))))
355
356(define no-serialization ;syntactic keyword for 'define-configuration'
357 '(no serialization))
358
359(define-syntax define-configuration
360 (lambda (s)
361 (syntax-case s (no-serialization prefix)
362 ((_ stem (field field-type+def doc custom-serializer ...) ...
363 (no-serialization))
364 (define-configuration-helper
365 #f #f #'(_ stem (field field-type+def doc custom-serializer ...)
366 ...)))
367 ((_ stem (field field-type+def doc custom-serializer ...) ...
368 (prefix serializer-prefix))
369 (define-configuration-helper
370 #t #'serializer-prefix #'(_ stem (field field-type+def
371 doc custom-serializer ...)
372 ...)))
373 ((_ stem (field field-type+def doc custom-serializer ...) ...)
374 (define-configuration-helper
375 #t #f #'(_ stem (field field-type+def doc custom-serializer ...)
376 ...))))))
377
378(define-syntax-rule (define-configuration/no-serialization
379 stem (field field-type+def
380 doc custom-serializer ...) ...)
381 (define-configuration stem (field field-type+def
382 doc custom-serializer ...) ...
383 (no-serialization)))
384
385(define (empty-serializer field-name val) "")
386(define serialize-package empty-serializer)
387
388;; Ideally this should be an implementation detail, but we export it
389;; to provide a simpler API that enables unsetting a configuration
390;; field that has a maybe type, but also a default value. We give it
391;; a value that sticks out to the reader when something goes wrong.
392;;
393;; An example use-case would be something like a network application
394;; that uses a default port, but the field can explicitly be unset to
395;; request a random port at startup.
396(define %unset-value '%unset-marker%)
397
398(define (maybe-value-set? value)
399 "Predicate to check whether a 'maybe' value was explicitly provided."
400 (not (eq? %unset-value value)))
401
402;; Ideally there should be a compiler macro for this predicate, that expands
403;; to a conditional that only instantiates the default value when needed.
404(define* (maybe-value value #:optional (default #f))
405 "Returns VALUE, unless it is the unset value, in which case it returns
406DEFAULT."
407 (if (maybe-value-set? value)
408 value
409 default))
410
411;; A little helper to make it easier to document all those fields.
412(define (generate-documentation documentation documentation-name)
413 (define (str x) (object->string x))
414
415 (define (package->symbol package)
416 "Return the first symbol name of a package that matches PACKAGE, else #f."
417 (let* ((module (file-name->module-name
418 (location-file (package-location package))))
419 (symbols (filter-map
420 identity
421 (module-map (lambda (symbol var)
422 (and (equal? package (variable-ref var))
423 symbol))
424 (resolve-module module)))))
425 (if (null? symbols)
426 #f
427 (first symbols))))
428
429 (define (generate configuration-name)
430 (match (assq-ref documentation configuration-name)
431 ((fields . sub-documentation)
432 `((deftp (% (category "Data Type") (name ,(str configuration-name)))
433 (para "Available " (code ,(str configuration-name)) " fields are:")
434 (table
435 (% (formatter (asis)))
436 ,@(map
437 (lambda (f)
438 (let ((field-name (configuration-field-name f))
439 (field-type (configuration-field-type f))
440 (field-docs (cdr (texi-fragment->stexi
441 (configuration-field-documentation f))))
442 (default (catch #t
443 (configuration-field-default-value-thunk f)
444 (lambda _ '%invalid))))
445 (define (show-default? val)
446 (or (string? val) (number? val) (boolean? val)
447 (package? val)
448 (and (symbol? val) (not (eq? val '%invalid)))
449 (and (list? val) (and-map show-default? val))))
450
451 (define (show-default val)
452 (cond
453 ((package? val)
454 (symbol->string (package->symbol val)))
455 (((list-of package?) val)
456 (format #f "(~{~a~^ ~})" (map package->symbol val)))
457 (else (str val))))
458
459 `(entry (% (heading
460 (code ,(str field-name))
461 ,@(if (show-default? default)
462 `(" (default: "
463 (code ,(show-default default)) ")")
464 '())
465 " (type: " ,(str field-type) ")"))
466 (para ,@field-docs)
467 ,@(append-map
468 generate
469 (filter-map
470 (match-lambda
471 ((name config)
472 (and (eq? name field-name)
473 config)))
474 sub-documentation)))))
475 fields)))))))
476 (stexi->texi `(*fragment* . ,(generate documentation-name))))
477
478(define (configuration->documentation configuration-symbol)
479 "Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when
480defining a configuration record with DEFINE-CONFIGURATION, and output the
481Texinfo documentation of its fields."
482 ;; This is helper for a simple, straight-forward application of
483 ;; GENERATE-DOCUMENTATION.
484 (let ((fields-getter (module-ref (current-module)
485 (symbol-append configuration-symbol
486 '-fields))))
487 (display (generate-documentation `((,configuration-symbol ,fields-getter))
488 configuration-symbol))))
489
490(define* (filter-configuration-fields configuration-fields fields
491 #:optional negate?)
492 "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS.
493If NEGATE? is @code{#t}, retrieve all fields except FIELDS."
494 (filter (lambda (field)
495 (let ((member? (member (configuration-field-name field) fields)))
496 (if (not negate?) member? (not member?))))
497 configuration-fields))
498
499
500(define* (interpose ls #:optional (delimiter "\n") (grammar 'infix))
501 "Same as @code{string-join}, but without join and string, returns a
502DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values."
503 (when (not (member grammar '(infix suffix)))
504 (raise
505 (formatted-message
506 (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.")
507 grammar)))
508 (fold-right (lambda (e acc)
509 (cons e
510 (if (and (null? acc) (eq? grammar 'infix))
511 acc
512 (cons delimiter acc))))
513 '() ls))
514
515(define-syntax define-enumerated-field-type
516 (lambda (x)
517 (syntax-case x (prefix)
518 ((_ name (option ...) (prefix serializer-prefix))
519 #`(begin
520 (define (#,(id #'name #'name #'?) x)
521 (memq x '(option ...)))
522 (define (#,(id #'name #'serializer-prefix #'serialize- #'name) field-name val)
523 (#,(id #'name #'serializer-prefix #'serialize-field) field-name val))))
524
525 ((_ name (option ...))
526 #`(define-enumerated-field-type name (option ...) (prefix #{}#))))))
527
528
529;;;
530;;; Commonly used predicates
531;;;
532
533(define (list-of pred?)
534 "Return a procedure that takes a list and check if all the elements of
535the list result in @code{#t} when applying PRED? on them."
536 (lambda (x)
537 (if (list? x)
538 (every pred? x)
539 #f)))
540
541(define list-of-packages?
542 (list-of (match-lambda
543 ((? package? pkg) #t)
544 (((? package? pkg) output) #t)
545 (_ #f))))
546
547(define list-of-strings?
548 (list-of string?))
549
550(define list-of-symbols?
551 (list-of symbol?))
552
553
554;;;
555;;; Special serializers
556;;;
557
558(define alist?
559 (list-of pair?))
560
561(define serialize-file-like empty-serializer)
562
563(define (text-config? config)
564 (list-of file-like?))
565
566(define (serialize-text-config field-name val)
567 #~(string-append
568 #$@(interpose
569 (map
570 (lambda (e)
571 #~(begin
572 (use-modules (ice-9 rdelim))
573 (with-fluids ((%default-port-encoding "UTF-8"))
574 (with-input-from-file #$e read-string))))
575 val)
576 "\n" 'suffix)))
577
578(define ((generic-serialize-alist-entry serialize-field) entry)
579 "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY."
580 (match entry
581 ((field . val) (serialize-field field val))))
582
583(define (generic-serialize-alist combine serialize-field fields)
584 "Generate a configuration from an association list FIELDS.
585
586SERIALIZE-FIELD is a procedure that takes two arguments, it will be
587applied on the fields and values of FIELDS using the
588@code{generic-serialize-alist-entry} procedure.
589
590COMBINE is a procedure that takes one or more arguments and combines
591all the alist entries into one value, @code{string-append} or
592@code{append} are usually good candidates for this."
593 (apply combine
594 (map (generic-serialize-alist-entry serialize-field) fields)))