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 ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (gnu services configuration)
  25   #:use-module (guix packages)
  26   #:use-module (guix records)
  27   #:use-module (guix gexp)
  28   #:use-module ((guix utils) #:select (source-properties->location))
  29   #:use-module ((guix diagnostics) #:select (formatted-message location-file))
  30   #:use-module ((guix modules) #:select (file-name->module-name))
  31   #:use-module (guix i18n)
  32   #:autoload   (texinfo) (texi-fragment->stexi)
  33   #:autoload   (texinfo serialize) (stexi->texi)
  34   #:use-module (ice-9 curried-definitions)
  35   #:use-module (ice-9 match)
  36   #:use-module (srfi srfi-1)
  37   #:use-module (srfi srfi-34)
  38   #:use-module (srfi srfi-35)
  39   #:export (configuration-field
  40             configuration-field-name
  41             configuration-field-type
  42             configuration-missing-field
  43             configuration-field-error
  44             configuration-field-serializer
  45             configuration-field-getter
  46             configuration-field-default-value-thunk
  47             configuration-field-documentation
  48
  49             configuration-error?
  50
  51             define-configuration
  52             define-configuration/no-serialization
  53             no-serialization
  54
  55             serialize-configuration
  56             define-maybe
  57             define-maybe/no-serialization
  58             validate-configuration
  59             generate-documentation
  60             configuration->documentation
  61             empty-serializer
  62             serialize-package
  63
  64             filter-configuration-fields
  65
  66             interpose
  67             list-of
  68
  69             list-of-strings?
  70             alist?
  71             serialize-file-like
  72             text-config?
  73             serialize-text-config
  74             generic-serialize-alist-entry
  75             generic-serialize-alist))
  76
  77 ;;; Commentary:
  78 ;;;
  79 ;;; Syntax for creating Scheme bindings to complex configuration files.
  80 ;;;
  81 ;;; Code:
  82
  83 (define-condition-type &configuration-error &error
  84   configuration-error?)
  85
  86 (define (configuration-error message)
  87   (raise (condition (&message (message message))
  88                     (&configuration-error))))
  89 (define (configuration-field-error field val)
  90   (configuration-error
  91    (format #f "Invalid value for field ~a: ~s" field val)))
  92 (define (configuration-missing-field kind field)
  93   (configuration-error
  94    (format #f "~a configuration missing required field ~a" kind field)))
  95 (define (configuration-no-default-value kind field)
  96   (configuration-error
  97    (format #f "The field `~a' of the `~a' configuration record \
  98 does not have a default value" field kind)))
  99
 100 (define-record-type* <configuration-field>
 101   configuration-field make-configuration-field configuration-field?
 102   (name configuration-field-name)
 103   (type configuration-field-type)
 104   (getter configuration-field-getter)
 105   (predicate configuration-field-predicate)
 106   (serializer configuration-field-serializer)
 107   (default-value-thunk configuration-field-default-value-thunk)
 108   (documentation configuration-field-documentation))
 109
 110 (define (serialize-configuration config fields)
 111   #~(string-append
 112      #$@(map (lambda (field)
 113                ((configuration-field-serializer field)
 114                 (configuration-field-name field)
 115                 ((configuration-field-getter field) config)))
 116              fields)))
 117
 118 (define (validate-configuration config fields)
 119   (for-each (lambda (field)
 120               (let ((val ((configuration-field-getter field) config)))
 121                 (unless ((configuration-field-predicate field) val)
 122                   (configuration-field-error
 123                    (configuration-field-name field) val))))
 124             fields))
 125
 126 (define-syntax-rule (id ctx parts ...)
 127   "Assemble PARTS into a raw (unhygienic) identifier."
 128   (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
 129
 130 (define (define-maybe-helper serialize? prefix syn)
 131   (syntax-case syn ()
 132     ((_ stem)
 133      (with-syntax
 134          ((stem?            (id #'stem #'stem #'?))
 135           (maybe-stem?      (id #'stem #'maybe- #'stem #'?))
 136           (serialize-stem   (if prefix
 137                                 (id #'stem prefix #'serialize- #'stem)
 138                                 (id #'stem #'serialize- #'stem)))
 139           (serialize-maybe-stem (if prefix
 140                                     (id #'stem prefix #'serialize-maybe- #'stem)
 141                                     (id #'stem #'serialize-maybe- #'stem))))
 142        #`(begin
 143            (define (maybe-stem? val)
 144              (or (eq? val 'disabled) (stem? val)))
 145            #,@(if serialize?
 146                   (list #'(define (serialize-maybe-stem field-name val)
 147                             (if (stem? val)
 148                                 (serialize-stem field-name val)
 149                                 "")))
 150                   '()))))))
 151
 152 (define-syntax define-maybe
 153   (lambda (x)
 154     (syntax-case x (no-serialization prefix)
 155       ((_ stem (no-serialization))
 156        (define-maybe-helper #f #f #'(_ stem)))
 157       ((_ stem (prefix serializer-prefix))
 158        (define-maybe-helper #t #'serializer-prefix #'(_ stem)))
 159       ((_ stem)
 160        (define-maybe-helper #t #f #'(_ stem))))))
 161
 162 (define-syntax-rule (define-maybe/no-serialization stem)
 163   (define-maybe stem (no-serialization)))
 164
 165 (define (define-configuration-helper serialize? serializer-prefix syn)
 166   (syntax-case syn ()
 167     ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
 168      (with-syntax (((field-getter ...)
 169                     (map (lambda (field)
 170                            (id #'stem #'stem #'- field))
 171                          #'(field ...)))
 172                    ((field-predicate ...)
 173                     (map (lambda (type)
 174                            (id #'stem type #'?))
 175                          #'(field-type ...)))
 176                    ((field-default ...)
 177                     (map (match-lambda
 178                            ((field-type default-value)
 179                             default-value)
 180                            ((field-type)
 181                             ;; Quote `undefined' to prevent a possibly
 182                             ;; unbound warning.
 183                             (syntax 'undefined)))
 184                          #'((field-type def ...) ...)))
 185                    ((field-serializer ...)
 186                     (map (lambda (type custom-serializer)
 187                            (and serialize?
 188                                 (match custom-serializer
 189                                   ((serializer)
 190                                    serializer)
 191                                   (()
 192                                    (if serializer-prefix
 193                                        (id #'stem
 194                                            serializer-prefix
 195                                            #'serialize- type)
 196                                        (id #'stem #'serialize- type))))))
 197                          #'(field-type ...)
 198                          #'((custom-serializer ...) ...))))
 199        #`(begin
 200            (define-record-type* #,(id #'stem #'< #'stem #'>)
 201              #,(id #'stem #'% #'stem)
 202              #,(id #'stem #'make- #'stem)
 203              #,(id #'stem #'stem #'?)
 204              (%location #,(id #'stem #'stem #'-location)
 205                         (default (and=> (current-source-location)
 206                                         source-properties->location))
 207                         (innate))
 208              #,@(map (lambda (name getter def)
 209                        (if (eq? (syntax->datum def) (quote 'undefined))
 210                            #`(#,name #,getter)
 211                            #`(#,name #,getter (default #,def))))
 212                      #'(field ...)
 213                      #'(field-getter ...)
 214                      #'(field-default ...)))
 215            (define #,(id #'stem #'stem #'-fields)
 216              (list (configuration-field
 217                     (name 'field)
 218                     (type 'field-type)
 219                     (getter field-getter)
 220                     (predicate field-predicate)
 221                     (serializer field-serializer)
 222                     (default-value-thunk
 223                       (lambda ()
 224                         (display '#,(id #'stem #'% #'stem))
 225                         (if (eq? (syntax->datum field-default)
 226                                  'undefined)
 227                             (configuration-no-default-value
 228                              '#,(id #'stem #'% #'stem) 'field)
 229                             field-default)))
 230                     (documentation doc))
 231                    ...))
 232            (define-syntax-rule (stem arg (... ...))
 233              (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
 234                (validate-configuration conf
 235                                        #,(id #'stem #'stem #'-fields))
 236                conf)))))))
 237
 238 (define no-serialization         ;syntactic keyword for 'define-configuration'
 239   '(no serialization))
 240
 241 (define-syntax define-configuration
 242   (lambda (s)
 243     (syntax-case s (no-serialization prefix)
 244       ((_ stem (field (field-type def ...) doc custom-serializer ...) ...
 245           (no-serialization))
 246        (define-configuration-helper
 247          #f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
 248                  ...)))
 249       ((_ stem  (field (field-type def ...) doc custom-serializer ...) ...
 250           (prefix serializer-prefix))
 251        (define-configuration-helper
 252          #t #'serializer-prefix #'(_ stem (field (field-type def ...)
 253                                                  doc custom-serializer ...)
 254                  ...)))
 255       ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
 256        (define-configuration-helper
 257          #t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
 258                  ...))))))
 259
 260 (define-syntax-rule (define-configuration/no-serialization
 261                       stem (field (field-type def ...)
 262                                   doc custom-serializer ...) ...)
 263   (define-configuration stem (field (field-type def ...)
 264                                     doc custom-serializer ...) ...
 265     (no-serialization)))
 266
 267 (define (empty-serializer field-name val) "")
 268 (define serialize-package empty-serializer)
 269
 270 ;; A little helper to make it easier to document all those fields.
 271 (define (generate-documentation documentation documentation-name)
 272   (define (str x) (object->string x))
 273
 274   (define (package->symbol package)
 275     "Return the first symbol name of a package that matches PACKAGE, else #f."
 276     (let* ((module (file-name->module-name
 277                     (location-file (package-location package))))
 278            (symbols (filter-map
 279                      identity
 280                      (module-map (lambda (symbol var)
 281                                    (and (equal? package (variable-ref var))
 282                                         symbol))
 283                                  (resolve-module module)))))
 284       (if (null? symbols)
 285           #f
 286           (first symbols))))
 287
 288   (define (generate configuration-name)
 289     (match (assq-ref documentation configuration-name)
 290       ((fields . sub-documentation)
 291        `((deftp (% (category "Data Type") (name ,(str configuration-name)))
 292            (para "Available " (code ,(str configuration-name)) " fields are:")
 293            (table
 294             (% (formatter (asis)))
 295             ,@(map
 296                (lambda (f)
 297                  (let ((field-name (configuration-field-name f))
 298                        (field-type (configuration-field-type f))
 299                        (field-docs (cdr (texi-fragment->stexi
 300                                          (configuration-field-documentation f))))
 301                        (default (catch #t
 302                                   (configuration-field-default-value-thunk f)
 303                                   (lambda _ '%invalid))))
 304                    (define (show-default? val)
 305                      (or (string? val) (number? val) (boolean? val)
 306                          (package? val)
 307                          (and (symbol? val) (not (eq? val '%invalid)))
 308                          (and (list? val) (and-map show-default? val))))
 309
 310                    (define (show-default val)
 311                      (cond
 312                       ((package? val)
 313                        (symbol->string (package->symbol val)))
 314                       (else (str val))))
 315
 316                    `(entry (% (heading
 317                                (code ,(str field-name))
 318                                ,@(if (show-default? default)
 319                                      `(" (default: "
 320                                        (code ,(show-default default)) ")")
 321                                      '())
 322                                " (type: " ,(str field-type) ")"))
 323                            (para ,@field-docs)
 324                            ,@(append-map
 325                               generate
 326                               (or (assq-ref sub-documentation field-name)
 327                                   '())))))
 328                fields)))))))
 329   (stexi->texi `(*fragment* . ,(generate documentation-name))))
 330
 331 (define (configuration->documentation configuration-symbol)
 332   "Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when
 333 defining a configuration record with DEFINE-CONFIGURATION, and output the
 334 Texinfo documentation of its fields."
 335   ;; This is helper for a simple, straight-forward application of
 336   ;; GENERATE-DOCUMENTATION.
 337   (let ((fields-getter (module-ref (current-module)
 338                                    (symbol-append configuration-symbol
 339                                                   '-fields))))
 340     (display (generate-documentation `((,configuration-symbol ,fields-getter))
 341                                      configuration-symbol))))
 342
 343 (define* (filter-configuration-fields configuration-fields fields
 344                                       #:optional negate?)
 345   "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS.
 346 If NEGATE? is @code{#t}, retrieve all fields except FIELDS."
 347   (filter (lambda (field)
 348             (let ((member? (member (configuration-field-name field) fields)))
 349               (if (not negate?) member? (not member?))))
 350           configuration-fields))
 351
 352
 353 (define* (interpose ls  #:optional (delimiter "\n") (grammar 'infix))
 354   "Same as @code{string-join}, but without join and string, returns an
 355 DELIMITER interposed LS.  Support 'infix and 'suffix GRAMMAR values."
 356   (when (not (member grammar '(infix suffix)))
 357     (raise
 358      (formatted-message
 359       (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.")
 360       grammar)))
 361   (fold-right (lambda (e acc)
 362                 (cons e
 363                       (if (and (null? acc) (eq? grammar 'infix))
 364                           acc
 365                           (cons delimiter acc))))
 366               '() ls))
 367
 368 (define (list-of pred?)
 369   "Return a procedure that takes a list and check if all the elements of
 370 the list result in @code{#t} when applying PRED? on them."
 371     (lambda (x)
 372       (if (list? x)
 373           (every pred? x)
 374           #f)))
 375
 376
 377 (define list-of-strings?
 378   (list-of string?))
 379
 380 (define alist? list?)
 381
 382 (define serialize-file-like empty-serializer)
 383
 384 (define (text-config? config)
 385   (list-of file-like?))
 386 (define (serialize-text-config field-name val)
 387   #~(string-append
 388      #$@(interpose
 389          (map
 390           (lambda (e)
 391             #~(begin
 392                 (use-modules (ice-9 rdelim))
 393                 (with-fluids ((%default-port-encoding "UTF-8"))
 394                   (with-input-from-file #$e read-string))))
 395           val)
 396          "\n" 'suffix)))
 397
 398 (define ((generic-serialize-alist-entry serialize-field) entry)
 399   "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY."
 400   (match entry
 401     ((field . val) (serialize-field field val))))
 402
 403 (define (generic-serialize-alist combine serialize-field fields)
 404   "Generate a configuration from an association list FIELDS.
 405
 406 SERIALIZE-FIELD is a procedure that takes two arguments, it will be
 407 applied on the fields and values of FIELDS using the
 408 @code{generic-serialize-alist-entry} procedure.
 409
 410 COMBINE is a procedure that takes one or more arguments and combines
 411 all the alist entries into one value, @code{string-append} or
 412 @code{append} are usually good candidates for this.
 413
 414 See the @code{serialize-alist} procedure in `@code{(gnu home services
 415 version-control}' for an example usage.)}"
 416   (apply combine
 417          (map (generic-serialize-alist-entry serialize-field) fields)))