gnu/services/configuration.scm

   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>
   5 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
   6 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (gnu services configuration)
  24   #:use-module (guix packages)
  25   #:use-module (guix records)
  26   #:use-module (guix gexp)
  27   #:use-module ((guix utils) #:select (source-properties->location))
  28   #:autoload   (texinfo) (texi-fragment->stexi)
  29   #:autoload   (texinfo serialize) (stexi->texi)
  30   #:use-module (ice-9 match)
  31   #:use-module ((srfi srfi-1) #:select (append-map))
  32   #:use-module (srfi srfi-34)
  33   #:use-module (srfi srfi-35)
  34   #:export (configuration-field
  35             configuration-field-name
  36             configuration-field-type
  37             configuration-missing-field
  38             configuration-field-error
  39             configuration-field-serializer
  40             configuration-field-getter
  41             configuration-field-default-value-thunk
  42             configuration-field-documentation
  43
  44             configuration-error?
  45
  46             define-configuration
  47             define-configuration/no-serialization
  48             no-serialization
  49
  50             serialize-configuration
  51             define-maybe
  52             define-maybe/no-serialization
  53             validate-configuration
  54             generate-documentation
  55             configuration->documentation
  56             empty-serializer
  57             serialize-package))
  58
  59 ;;; Commentary:
  60 ;;;
  61 ;;; Syntax for creating Scheme bindings to complex configuration files.
  62 ;;;
  63 ;;; Code:
  64
  65 (define-condition-type &configuration-error &error
  66   configuration-error?)
  67
  68 (define (configuration-error message)
  69   (raise (condition (&message (message message))
  70                     (&configuration-error))))
  71 (define (configuration-field-error field val)
  72   (configuration-error
  73    (format #f "Invalid value for field ~a: ~s" field val)))
  74 (define (configuration-missing-field kind field)
  75   (configuration-error
  76    (format #f "~a configuration missing required field ~a" kind field)))
  77 (define (configuration-no-default-value kind field)
  78   (configuration-error
  79    (format #f "The field `~a' of the `~a' configuration record \
  80 does not have a default value" field kind)))
  81
  82 (define-record-type* <configuration-field>
  83   configuration-field make-configuration-field configuration-field?
  84   (name configuration-field-name)
  85   (type configuration-field-type)
  86   (getter configuration-field-getter)
  87   (predicate configuration-field-predicate)
  88   (serializer configuration-field-serializer)
  89   (default-value-thunk configuration-field-default-value-thunk)
  90   (documentation configuration-field-documentation))
  91
  92 (define (serialize-configuration config fields)
  93   #~(string-append
  94      #$@(map (lambda (field)
  95                ((configuration-field-serializer field)
  96                 (configuration-field-name field)
  97                 ((configuration-field-getter field) config)))
  98              fields)))
  99
 100 (define (validate-configuration config fields)
 101   (for-each (lambda (field)
 102               (let ((val ((configuration-field-getter field) config)))
 103                 (unless ((configuration-field-predicate field) val)
 104                   (configuration-field-error
 105                    (configuration-field-name field) val))))
 106             fields))
 107
 108 (define-syntax-rule (id ctx parts ...)
 109   "Assemble PARTS into a raw (unhygienic) identifier."
 110   (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
 111
 112 (define (define-maybe-helper serialize? syn)
 113   (syntax-case syn ()
 114     ((_ stem)
 115      (with-syntax
 116          ((stem?            (id #'stem #'stem #'?))
 117           (maybe-stem?      (id #'stem #'maybe- #'stem #'?))
 118           (serialize-stem   (id #'stem #'serialize- #'stem))
 119           (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
 120        #`(begin
 121            (define (maybe-stem? val)
 122              (or (eq? val 'disabled) (stem? val)))
 123            #,@(if serialize?
 124                   (list #'(define (serialize-maybe-stem field-name val)
 125                             (if (stem? val)
 126                                 (serialize-stem field-name val)
 127                                 "")))
 128                   '()))))))
 129
 130 (define-syntax define-maybe
 131   (lambda (x)
 132     (syntax-case x (no-serialization)
 133       ((_ stem (no-serialization))
 134        (define-maybe-helper #f #'(_ stem)))
 135       ((_ stem)
 136        (define-maybe-helper #t #'(_ stem))))))
 137
 138 (define-syntax-rule (define-maybe/no-serialization stem)
 139   (define-maybe stem (no-serialization)))
 140
 141 (define (define-configuration-helper serialize? syn)
 142   (syntax-case syn ()
 143     ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
 144      (with-syntax (((field-getter ...)
 145                     (map (lambda (field)
 146                            (id #'stem #'stem #'- field))
 147                          #'(field ...)))
 148                    ((field-predicate ...)
 149                     (map (lambda (type)
 150                            (id #'stem type #'?))
 151                          #'(field-type ...)))
 152                    ((field-default ...)
 153                     (map (match-lambda
 154                            ((field-type default-value)
 155                             default-value)
 156                            ((field-type)
 157                             ;; Quote `undefined' to prevent a possibly
 158                             ;; unbound warning.
 159                             (syntax 'undefined)))
 160                          #'((field-type def ...) ...)))
 161                    ((field-serializer ...)
 162                     (map (lambda (type custom-serializer)
 163                            (and serialize?
 164                                 (match custom-serializer
 165                                   ((serializer)
 166                                    serializer)
 167                                   (()
 168                                   (id #'stem #'serialize- type)))))
 169                          #'(field-type ...)
 170                          #'((custom-serializer ...) ...))))
 171        #`(begin
 172            (define-record-type* #,(id #'stem #'< #'stem #'>)
 173              #,(id #'stem #'% #'stem)
 174              #,(id #'stem #'make- #'stem)
 175              #,(id #'stem #'stem #'?)
 176              (%location #,(id #'stem #'stem #'-location)
 177                         (default (and=> (current-source-location)
 178                                         source-properties->location))
 179                         (innate))
 180              #,@(map (lambda (name getter def)
 181                        (if (eq? (syntax->datum def) (quote 'undefined))
 182                            #`(#,name #,getter)
 183                            #`(#,name #,getter (default #,def))))
 184                      #'(field ...)
 185                      #'(field-getter ...)
 186                      #'(field-default ...)))
 187            (define #,(id #'stem #'stem #'-fields)
 188              (list (configuration-field
 189                     (name 'field)
 190                     (type 'field-type)
 191                     (getter field-getter)
 192                     (predicate field-predicate)
 193                     (serializer field-serializer)
 194                     (default-value-thunk
 195                       (lambda ()
 196                         (display '#,(id #'stem #'% #'stem))
 197                         (if (eq? (syntax->datum field-default)
 198                                  'undefined)
 199                             (configuration-no-default-value
 200                              '#,(id #'stem #'% #'stem) 'field)
 201                             field-default)))
 202                     (documentation doc))
 203                    ...))
 204            (define-syntax-rule (stem arg (... ...))
 205              (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
 206                (validate-configuration conf
 207                                        #,(id #'stem #'stem #'-fields))
 208                conf)))))))
 209
 210 (define no-serialization         ;syntactic keyword for 'define-configuration'
 211   '(no serialization))
 212
 213 (define-syntax define-configuration
 214   (lambda (s)
 215     (syntax-case s (no-serialization)
 216       ((_ stem (field (field-type def ...) doc custom-serializer ...) ...
 217           (no-serialization))
 218        (define-configuration-helper
 219          #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
 220                  ...)))
 221       ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
 222        (define-configuration-helper
 223          #t #'(_ stem (field (field-type def ...) doc custom-serializer ...)
 224                  ...))))))
 225
 226 (define-syntax-rule (define-configuration/no-serialization
 227                       stem (field (field-type def ...)
 228                                   doc custom-serializer ...) ...)
 229   (define-configuration stem (field (field-type def ...)
 230                                     doc custom-serializer ...) ...
 231     (no-serialization)))
 232
 233 (define (empty-serializer field-name val) "")
 234 (define serialize-package empty-serializer)
 235
 236 ;; A little helper to make it easier to document all those fields.
 237 (define (generate-documentation documentation documentation-name)
 238   (define (str x) (object->string x))
 239   (define (generate configuration-name)
 240     (match (assq-ref documentation configuration-name)
 241       ((fields . sub-documentation)
 242        `((para "Available " (code ,(str configuration-name)) " fields are:")
 243          ,@(map
 244             (lambda (f)
 245               (let ((field-name (configuration-field-name f))
 246                     (field-type (configuration-field-type f))
 247                     (field-docs (cdr (texi-fragment->stexi
 248                                       (configuration-field-documentation f))))
 249                     (default (catch #t
 250                                (configuration-field-default-value-thunk f)
 251                                (lambda _ '%invalid))))
 252                 (define (show-default? val)
 253                   (or (string? val) (number? val) (boolean? val)
 254                       (and (symbol? val) (not (eq? val '%invalid)))
 255                       (and (list? val) (and-map show-default? val))))
 256                 `(deftypevr (% (category
 257                                 (code ,(str configuration-name)) " parameter")
 258                                (data-type ,(str field-type))
 259                                (name ,(str field-name)))
 260                    ,@field-docs
 261                    ,@(if (show-default? default)
 262                          `((para "Defaults to " (samp ,(str default)) "."))
 263                          '())
 264                    ,@(append-map
 265                       generate
 266                       (or (assq-ref sub-documentation field-name) '())))))
 267             fields)))))
 268   (stexi->texi `(*fragment* . ,(generate documentation-name))))
 269
 270 (define (configuration->documentation configuration-symbol)
 271   "Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when
 272 defining a configuration record with DEFINE-CONFIGURATION, and output the
 273 Texinfo documentation of its fields."
 274   ;; This is helper for a simple, straight-forward application of
 275   ;; GENERATE-DOCUMENTATION.
 276   (let ((fields-getter (module-ref (current-module)
 277                                    (symbol-append configuration-symbol
 278                                                   '-fields))))
 279     (display (generate-documentation `((,configuration-symbol ,fields-getter))
 280                                      configuration-symbol))))