281 lines
11 KiB
Scheme
281 lines
11 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
|
|
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
|
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
|
|
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
|
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
|
;;;
|
|
;;; This file is part of GNU Guix.
|
|
;;;
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (gnu services configuration)
|
|
#:use-module (guix packages)
|
|
#:use-module (guix records)
|
|
#:use-module (guix gexp)
|
|
#:use-module ((guix utils) #:select (source-properties->location))
|
|
#:autoload (texinfo) (texi-fragment->stexi)
|
|
#:autoload (texinfo serialize) (stexi->texi)
|
|
#:use-module (ice-9 match)
|
|
#:use-module ((srfi srfi-1) #:select (append-map))
|
|
#:use-module (srfi srfi-34)
|
|
#:use-module (srfi srfi-35)
|
|
#:export (configuration-field
|
|
configuration-field-name
|
|
configuration-field-type
|
|
configuration-missing-field
|
|
configuration-field-error
|
|
configuration-field-serializer
|
|
configuration-field-getter
|
|
configuration-field-default-value-thunk
|
|
configuration-field-documentation
|
|
|
|
configuration-error?
|
|
|
|
define-configuration
|
|
define-configuration/no-serialization
|
|
no-serialization
|
|
|
|
serialize-configuration
|
|
define-maybe
|
|
define-maybe/no-serialization
|
|
validate-configuration
|
|
generate-documentation
|
|
configuration->documentation
|
|
empty-serializer
|
|
serialize-package))
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; Syntax for creating Scheme bindings to complex configuration files.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-condition-type &configuration-error &error
|
|
configuration-error?)
|
|
|
|
(define (configuration-error message)
|
|
(raise (condition (&message (message message))
|
|
(&configuration-error))))
|
|
(define (configuration-field-error field val)
|
|
(configuration-error
|
|
(format #f "Invalid value for field ~a: ~s" field val)))
|
|
(define (configuration-missing-field kind field)
|
|
(configuration-error
|
|
(format #f "~a configuration missing required field ~a" kind field)))
|
|
(define (configuration-no-default-value kind field)
|
|
(configuration-error
|
|
(format #f "The field `~a' of the `~a' configuration record \
|
|
does not have a default value" field kind)))
|
|
|
|
(define-record-type* <configuration-field>
|
|
configuration-field make-configuration-field configuration-field?
|
|
(name configuration-field-name)
|
|
(type configuration-field-type)
|
|
(getter configuration-field-getter)
|
|
(predicate configuration-field-predicate)
|
|
(serializer configuration-field-serializer)
|
|
(default-value-thunk configuration-field-default-value-thunk)
|
|
(documentation configuration-field-documentation))
|
|
|
|
(define (serialize-configuration config fields)
|
|
#~(string-append
|
|
#$@(map (lambda (field)
|
|
((configuration-field-serializer field)
|
|
(configuration-field-name field)
|
|
((configuration-field-getter field) config)))
|
|
fields)))
|
|
|
|
(define (validate-configuration config fields)
|
|
(for-each (lambda (field)
|
|
(let ((val ((configuration-field-getter field) config)))
|
|
(unless ((configuration-field-predicate field) val)
|
|
(configuration-field-error
|
|
(configuration-field-name field) val))))
|
|
fields))
|
|
|
|
(define-syntax-rule (id ctx parts ...)
|
|
"Assemble PARTS into a raw (unhygienic) identifier."
|
|
(datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
|
|
|
|
(define (define-maybe-helper serialize? syn)
|
|
(syntax-case syn ()
|
|
((_ stem)
|
|
(with-syntax
|
|
((stem? (id #'stem #'stem #'?))
|
|
(maybe-stem? (id #'stem #'maybe- #'stem #'?))
|
|
(serialize-stem (id #'stem #'serialize- #'stem))
|
|
(serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
|
|
#`(begin
|
|
(define (maybe-stem? val)
|
|
(or (eq? val 'disabled) (stem? val)))
|
|
#,@(if serialize?
|
|
(list #'(define (serialize-maybe-stem field-name val)
|
|
(if (stem? val)
|
|
(serialize-stem field-name val)
|
|
"")))
|
|
'()))))))
|
|
|
|
(define-syntax define-maybe
|
|
(lambda (x)
|
|
(syntax-case x (no-serialization)
|
|
((_ stem (no-serialization))
|
|
(define-maybe-helper #f #'(_ stem)))
|
|
((_ stem)
|
|
(define-maybe-helper #t #'(_ stem))))))
|
|
|
|
(define-syntax-rule (define-maybe/no-serialization stem)
|
|
(define-maybe stem (no-serialization)))
|
|
|
|
(define (define-configuration-helper serialize? syn)
|
|
(syntax-case syn ()
|
|
((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
|
|
(with-syntax (((field-getter ...)
|
|
(map (lambda (field)
|
|
(id #'stem #'stem #'- field))
|
|
#'(field ...)))
|
|
((field-predicate ...)
|
|
(map (lambda (type)
|
|
(id #'stem type #'?))
|
|
#'(field-type ...)))
|
|
((field-default ...)
|
|
(map (match-lambda
|
|
((field-type default-value)
|
|
default-value)
|
|
((field-type)
|
|
;; Quote `undefined' to prevent a possibly
|
|
;; unbound warning.
|
|
(syntax 'undefined)))
|
|
#'((field-type def ...) ...)))
|
|
((field-serializer ...)
|
|
(map (lambda (type custom-serializer)
|
|
(and serialize?
|
|
(match custom-serializer
|
|
((serializer)
|
|
serializer)
|
|
(()
|
|
(id #'stem #'serialize- type)))))
|
|
#'(field-type ...)
|
|
#'((custom-serializer ...) ...))))
|
|
#`(begin
|
|
(define-record-type* #,(id #'stem #'< #'stem #'>)
|
|
#,(id #'stem #'% #'stem)
|
|
#,(id #'stem #'make- #'stem)
|
|
#,(id #'stem #'stem #'?)
|
|
(%location #,(id #'stem #'stem #'-location)
|
|
(default (and=> (current-source-location)
|
|
source-properties->location))
|
|
(innate))
|
|
#,@(map (lambda (name getter def)
|
|
(if (eq? (syntax->datum def) (quote 'undefined))
|
|
#`(#,name #,getter)
|
|
#`(#,name #,getter (default #,def))))
|
|
#'(field ...)
|
|
#'(field-getter ...)
|
|
#'(field-default ...)))
|
|
(define #,(id #'stem #'stem #'-fields)
|
|
(list (configuration-field
|
|
(name 'field)
|
|
(type 'field-type)
|
|
(getter field-getter)
|
|
(predicate field-predicate)
|
|
(serializer field-serializer)
|
|
(default-value-thunk
|
|
(lambda ()
|
|
(display '#,(id #'stem #'% #'stem))
|
|
(if (eq? (syntax->datum field-default)
|
|
'undefined)
|
|
(configuration-no-default-value
|
|
'#,(id #'stem #'% #'stem) 'field)
|
|
field-default)))
|
|
(documentation doc))
|
|
...))
|
|
(define-syntax-rule (stem arg (... ...))
|
|
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
|
|
(validate-configuration conf
|
|
#,(id #'stem #'stem #'-fields))
|
|
conf)))))))
|
|
|
|
(define no-serialization ;syntactic keyword for 'define-configuration'
|
|
'(no serialization))
|
|
|
|
(define-syntax define-configuration
|
|
(lambda (s)
|
|
(syntax-case s (no-serialization)
|
|
((_ stem (field (field-type def ...) doc custom-serializer ...) ...
|
|
(no-serialization))
|
|
(define-configuration-helper
|
|
#f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
|
|
...)))
|
|
((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
|
|
(define-configuration-helper
|
|
#t #'(_ stem (field (field-type def ...) doc custom-serializer ...)
|
|
...))))))
|
|
|
|
(define-syntax-rule (define-configuration/no-serialization
|
|
stem (field (field-type def ...)
|
|
doc custom-serializer ...) ...)
|
|
(define-configuration stem (field (field-type def ...)
|
|
doc custom-serializer ...) ...
|
|
(no-serialization)))
|
|
|
|
(define (empty-serializer field-name val) "")
|
|
(define serialize-package empty-serializer)
|
|
|
|
;; A little helper to make it easier to document all those fields.
|
|
(define (generate-documentation documentation documentation-name)
|
|
(define (str x) (object->string x))
|
|
(define (generate configuration-name)
|
|
(match (assq-ref documentation configuration-name)
|
|
((fields . sub-documentation)
|
|
`((para "Available " (code ,(str configuration-name)) " fields are:")
|
|
,@(map
|
|
(lambda (f)
|
|
(let ((field-name (configuration-field-name f))
|
|
(field-type (configuration-field-type f))
|
|
(field-docs (cdr (texi-fragment->stexi
|
|
(configuration-field-documentation f))))
|
|
(default (catch #t
|
|
(configuration-field-default-value-thunk f)
|
|
(lambda _ '%invalid))))
|
|
(define (show-default? val)
|
|
(or (string? val) (number? val) (boolean? val)
|
|
(and (symbol? val) (not (eq? val '%invalid)))
|
|
(and (list? val) (and-map show-default? val))))
|
|
`(deftypevr (% (category
|
|
(code ,(str configuration-name)) " parameter")
|
|
(data-type ,(str field-type))
|
|
(name ,(str field-name)))
|
|
,@field-docs
|
|
,@(if (show-default? default)
|
|
`((para "Defaults to " (samp ,(str default)) "."))
|
|
'())
|
|
,@(append-map
|
|
generate
|
|
(or (assq-ref sub-documentation field-name) '())))))
|
|
fields)))))
|
|
(stexi->texi `(*fragment* . ,(generate documentation-name))))
|
|
|
|
(define (configuration->documentation configuration-symbol)
|
|
"Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when
|
|
defining a configuration record with DEFINE-CONFIGURATION, and output the
|
|
Texinfo documentation of its fields."
|
|
;; This is helper for a simple, straight-forward application of
|
|
;; GENERATE-DOCUMENTATION.
|
|
(let ((fields-getter (module-ref (current-module)
|
|
(symbol-append configuration-symbol
|
|
'-fields))))
|
|
(display (generate-documentation `((,configuration-symbol ,fields-getter))
|
|
configuration-symbol))))
|