configuration.scm 7.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185
  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 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. (define-module (gnu services configuration)
  21. #:use-module (guix packages)
  22. #:use-module (guix records)
  23. #:use-module (guix gexp)
  24. #:autoload (texinfo) (texi-fragment->stexi)
  25. #:autoload (texinfo serialize) (stexi->texi)
  26. #:use-module (ice-9 match)
  27. #:use-module ((srfi srfi-1) #:select (append-map))
  28. #:use-module (srfi srfi-34)
  29. #:use-module (srfi srfi-35)
  30. #:export (configuration-field
  31. configuration-field-name
  32. configuration-field-type
  33. configuration-missing-field
  34. configuration-field-error
  35. configuration-field-serializer
  36. configuration-field-getter
  37. configuration-field-default-value-thunk
  38. configuration-field-documentation
  39. serialize-configuration
  40. define-maybe
  41. define-configuration
  42. validate-configuration
  43. generate-documentation
  44. serialize-package))
  45. ;;; Commentary:
  46. ;;;
  47. ;;; Syntax for creating Scheme bindings to complex configuration files.
  48. ;;;
  49. ;;; Code:
  50. (define-condition-type &configuration-error &error
  51. configuration-error?)
  52. (define (configuration-error message)
  53. (raise (condition (&message (message message))
  54. (&configuration-error))))
  55. (define (configuration-field-error field val)
  56. (configuration-error
  57. (format #f "Invalid value for field ~a: ~s" field val)))
  58. (define (configuration-missing-field kind field)
  59. (configuration-error
  60. (format #f "~a configuration missing required field ~a" kind field)))
  61. (define-record-type* <configuration-field>
  62. configuration-field make-configuration-field configuration-field?
  63. (name configuration-field-name)
  64. (type configuration-field-type)
  65. (getter configuration-field-getter)
  66. (predicate configuration-field-predicate)
  67. (serializer configuration-field-serializer)
  68. (default-value-thunk configuration-field-default-value-thunk)
  69. (documentation configuration-field-documentation))
  70. (define (serialize-configuration config fields)
  71. (for-each (lambda (field)
  72. ((configuration-field-serializer field)
  73. (configuration-field-name field)
  74. ((configuration-field-getter field) config)))
  75. fields))
  76. (define (validate-configuration config fields)
  77. (for-each (lambda (field)
  78. (let ((val ((configuration-field-getter field) config)))
  79. (unless ((configuration-field-predicate field) val)
  80. (configuration-field-error
  81. (configuration-field-name field) val))))
  82. fields))
  83. (define-syntax-rule (id ctx parts ...)
  84. "Assemble PARTS into a raw (unhygienic) identifier."
  85. (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
  86. (define-syntax define-maybe
  87. (lambda (x)
  88. (syntax-case x ()
  89. ((_ stem)
  90. (with-syntax
  91. ((stem? (id #'stem #'stem #'?))
  92. (maybe-stem? (id #'stem #'maybe- #'stem #'?))
  93. (serialize-stem (id #'stem #'serialize- #'stem))
  94. (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
  95. #'(begin
  96. (define (maybe-stem? val)
  97. (or (eq? val 'disabled) (stem? val)))
  98. (define (serialize-maybe-stem field-name val)
  99. (when (stem? val) (serialize-stem field-name val)))))))))
  100. (define-syntax define-configuration
  101. (lambda (stx)
  102. (syntax-case stx ()
  103. ((_ stem (field (field-type def) doc) ...)
  104. (with-syntax (((field-getter ...)
  105. (map (lambda (field)
  106. (id #'stem #'stem #'- field))
  107. #'(field ...)))
  108. ((field-predicate ...)
  109. (map (lambda (type)
  110. (id #'stem type #'?))
  111. #'(field-type ...)))
  112. ((field-serializer ...)
  113. (map (lambda (type)
  114. (id #'stem #'serialize- type))
  115. #'(field-type ...))))
  116. #`(begin
  117. (define-record-type* #,(id #'stem #'< #'stem #'>)
  118. #,(id #'stem #'% #'stem)
  119. #,(id #'stem #'make- #'stem)
  120. #,(id #'stem #'stem #'?)
  121. (field field-getter (default def))
  122. ...)
  123. (define #,(id #'stem #'stem #'-fields)
  124. (list (configuration-field
  125. (name 'field)
  126. (type 'field-type)
  127. (getter field-getter)
  128. (predicate field-predicate)
  129. (serializer field-serializer)
  130. (default-value-thunk (lambda () def))
  131. (documentation doc))
  132. ...))
  133. (define-syntax-rule (stem arg (... ...))
  134. (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
  135. (validate-configuration conf
  136. #,(id #'stem #'stem #'-fields))
  137. conf))))))))
  138. (define (serialize-package field-name val)
  139. #f)
  140. ;; A little helper to make it easier to document all those fields.
  141. (define (generate-documentation documentation documentation-name)
  142. (define (str x) (object->string x))
  143. (define (generate configuration-name)
  144. (match (assq-ref documentation configuration-name)
  145. ((fields . sub-documentation)
  146. `((para "Available " (code ,(str configuration-name)) " fields are:")
  147. ,@(map
  148. (lambda (f)
  149. (let ((field-name (configuration-field-name f))
  150. (field-type (configuration-field-type f))
  151. (field-docs (cdr (texi-fragment->stexi
  152. (configuration-field-documentation f))))
  153. (default (catch #t
  154. (configuration-field-default-value-thunk f)
  155. (lambda _ '%invalid))))
  156. (define (show-default? val)
  157. (or (string? val) (number? val) (boolean? val)
  158. (and (symbol? val) (not (eq? val '%invalid)))
  159. (and (list? val) (and-map show-default? val))))
  160. `(deftypevr (% (category
  161. (code ,(str configuration-name)) " parameter")
  162. (data-type ,(str field-type))
  163. (name ,(str field-name)))
  164. ,@field-docs
  165. ,@(if (show-default? default)
  166. `((para "Defaults to " (samp ,(str default)) "."))
  167. '())
  168. ,@(append-map
  169. generate
  170. (or (assq-ref sub-documentation field-name) '())))))
  171. fields)))))
  172. (stexi->texi `(*fragment* . ,(generate documentation-name))))