guix/gnu/services/configuration.scm

;;; 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, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;;
;;; 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))
  #:use-module ((guix diagnostics)
                #:select (formatted-message location-file &error-location
                          warning))
  #:use-module ((guix modules) #:select (file-name->module-name))
  #:use-module (guix i18n)
  #:autoload   (texinfo) (texi-fragment->stexi)
  #:autoload   (texinfo serialize) (stexi->texi)
  #:use-module (ice-9 curried-definitions)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #: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-sanitizer
            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
            %unset-value
            maybe-value
            maybe-value-set?
            generate-documentation
            configuration->documentation
            empty-serializer
            serialize-package

            filter-configuration-fields

            interpose
            list-of

            list-of-strings?
            alist?
            serialize-file-like
            text-config?
            serialize-text-config
            generic-serialize-alist-entry
            generic-serialize-alist))

;;; 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 loc field value)
  (raise (apply
          make-compound-condition
          (formatted-message (G_ "invalid value ~s for field '~a'")
                             value field)
          (condition (&configuration-error))
          (if loc
              (list (condition
                     (&error-location (location loc))))
              '()))))

(define (configuration-missing-field kind field)
  (configuration-error
   (format #f "~a configuration missing required field ~a" kind field)))
(define (configuration-missing-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)
  (sanitizer configuration-field-sanitizer)
  (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-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? prefix syn)
  (syntax-case syn ()
    ((_ stem)
     (with-syntax
         ((stem?            (id #'stem #'stem #'?))
          (maybe-stem?      (id #'stem #'maybe- #'stem #'?))
          (serialize-stem   (if prefix
                                (id #'stem prefix #'serialize- #'stem)
                                (id #'stem #'serialize- #'stem)))
          (serialize-maybe-stem (if prefix
                                    (id #'stem prefix #'serialize-maybe- #'stem)
                                    (id #'stem #'serialize-maybe- #'stem))))
       #`(begin
           (define (maybe-stem? val)
             (or (not (maybe-value-set? val))
                 (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 prefix)
      ((_ stem (no-serialization))
       (define-maybe-helper #f #f #'(_ stem)))
      ((_ stem (prefix serializer-prefix))
       (define-maybe-helper #t #'serializer-prefix #'(_ stem)))
      ((_ stem)
       (define-maybe-helper #t #f #'(_ stem))))))

(define-syntax-rule (define-maybe/no-serialization stem)
  (define-maybe stem (no-serialization)))

(define (normalize-field-type+def s)
  (syntax-case s ()
    ((field-type def)
     (identifier? #'field-type)
     (values #'(field-type def)))
    ((field-type)
     (identifier? #'field-type)
     (values #'(field-type %unset-value)))
    (field-type
     (identifier? #'field-type)
     (values #'(field-type %unset-value)))))

(define (define-configuration-helper serialize? serializer-prefix syn)

  (define (normalize-extra-args s)
    "Extract and normalize arguments following @var{doc}."
    (let loop ((s s)
               (sanitizer* %unset-value)
               (serializer* %unset-value))
      (syntax-case s (sanitizer serializer empty-serializer)
        (((sanitizer proc) tail ...)
         (if (maybe-value-set? sanitizer*)
             (syntax-violation 'sanitizer "duplicate entry"
                               #'proc)
             (loop #'(tail ...) #'proc serializer*)))
        (((serializer proc) tail ...)
         (if (maybe-value-set? serializer*)
             (syntax-violation 'serializer "duplicate or conflicting entry"
                               #'proc)
             (loop #'(tail ...) sanitizer* #'proc)))
        ((empty-serializer tail ...)
         (if (maybe-value-set? serializer*)
             (syntax-violation 'empty-serializer
                               "duplicate or conflicting entry" #f)
             (loop #'(tail ...) sanitizer* #'empty-serializer)))
        (()  ; stop condition
         (values (list sanitizer* serializer*)))
        ((proc)  ; TODO: deprecated, to be removed.
         (null? (filter-map maybe-value-set? (list sanitizer* serializer*)))
         (begin
           (warning #f (G_ "specifying serializers after documentation is \
deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
           (values (list %unset-value #'proc)))))))

  (syntax-case syn ()
    ((_ stem (field field-type+def doc extra-args ...) ...)
     (with-syntax
         ((((field-type def) ...)
           (map normalize-field-type+def #'(field-type+def ...)))
          (((sanitizer* serializer*) ...)
           (map normalize-extra-args #'((extra-args ...) ...))))
       (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 def) ...)))
            ((field-sanitizer ...)
             (map maybe-value #'(sanitizer* ...)))
            ((field-serializer ...)
             (map (lambda (type proc)
                    (and serialize?
                         (or (maybe-value proc)
                             (if serializer-prefix
                                 (id #'stem serializer-prefix #'serialize- type)
                                 (id #'stem #'serialize- type)))))
                  #'(field-type ...)
                  #'(serializer* ...))))
         (define (default-field-sanitizer name pred)
           ;; Define a macro for use as a record field sanitizer, where NAME
           ;; is the name of the field and PRED is the predicate that tells
           ;; whether a value is valid for this field.
           #`(define-syntax #,(id #'stem #'validate- #'stem #'- name)
               (lambda (s)
                 ;; Make sure the given VALUE, for field NAME, passes PRED.
                 (syntax-case s ()
                   ((_ value)
                    (with-syntax ((name #'#,name)
                                  (pred #'#,pred)
                                  (loc (datum->syntax #'value
                                                      (syntax-source #'value))))
                      #'(if (pred value)
                            value
                            (configuration-field-error
                             (and=> 'loc source-properties->location)
                             'name value))))))))

         #`(begin
             ;; Define field validation macros.
             #,@(filter-map (lambda (name pred sanitizer)
                              (if sanitizer
                                  #f
                                  (default-field-sanitizer name pred)))
                            #'(field ...)
                            #'(field-predicate ...)
                            #'(field-sanitizer ...))

             (define-record-type* #,(id #'stem #'< #'stem #'>)
               stem
               #,(id #'stem #'make- #'stem)
               #,(id #'stem #'stem #'?)
               #,@(map (lambda (name getter def sanitizer)
                         #`(#,name #,getter
                                   (default #,def)
                                   (sanitize
                                    #,(or sanitizer
                                          (id #'stem
                                              #'validate- #'stem #'- name)))))
                       #'(field ...)
                       #'(field-getter ...)
                       #'(field-default ...)
                       #'(field-sanitizer ...))
               (%location #,(id #'stem #'stem #'-source-location)
                          (default (and=> (current-source-location)
                                          source-properties->location))
                          (innate)))

             (define #,(id #'stem #'stem #'-fields)
               (list (configuration-field
                      (name 'field)
                      (type 'field-type)
                      (getter field-getter)
                      (predicate field-predicate)
                      (sanitizer
                       (or field-sanitizer
                           (id #'stem #'validate- #'stem #'- #'field)))
                      (serializer field-serializer)
                      (default-value-thunk
                        (lambda ()
                          (if (maybe-value-set? (syntax->datum field-default))
                              field-default
                              (configuration-missing-default-value
                               '#,(id #'stem #'% #'stem) 'field))))
                      (documentation doc))
                     ...))))))))

(define no-serialization         ;syntactic keyword for 'define-configuration'
  '(no serialization))

(define-syntax define-configuration
  (lambda (s)
    (syntax-case s (no-serialization prefix)
      ((_ stem (field field-type+def doc custom-serializer ...) ...
          (no-serialization))
       (define-configuration-helper
         #f #f #'(_ stem (field field-type+def doc custom-serializer ...)
                 ...)))
      ((_ stem  (field field-type+def doc custom-serializer ...) ...
          (prefix serializer-prefix))
       (define-configuration-helper
         #t #'serializer-prefix #'(_ stem (field field-type+def
                                                 doc custom-serializer ...)
                 ...)))
      ((_ stem (field field-type+def doc custom-serializer ...) ...)
       (define-configuration-helper
         #t #f #'(_ 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)

;; Ideally this should be an implementation detail, but we export it
;; to provide a simpler API that enables unsetting a configuration
;; field that has a maybe type, but also a default value.  We give it
;; a value that sticks out to the reader when something goes wrong.
;;
;; An example use-case would be something like a network application
;; that uses a default port, but the field can explicitly be unset to
;; request a random port at startup.
(define %unset-value '%unset-marker%)

(define (maybe-value-set? value)
  "Predicate to check whether a 'maybe' value was explicitly provided."
  (not (eq? %unset-value value)))

;; Ideally there should be a compiler macro for this predicate, that expands
;; to a conditional that only instantiates the default value when needed.
(define* (maybe-value value #:optional (default #f))
  "Returns VALUE, unless it is the unset value, in which case it returns
DEFAULT."
  (if (maybe-value-set? value)
      value
      default))

;; 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 (package->symbol package)
    "Return the first symbol name of a package that matches PACKAGE, else #f."
    (let* ((module (file-name->module-name
                    (location-file (package-location package))))
           (symbols (filter-map
                     identity
                     (module-map (lambda (symbol var)
                                   (and (equal? package (variable-ref var))
                                        symbol))
                                 (resolve-module module)))))
      (if (null? symbols)
          #f
          (first symbols))))

  (define (generate configuration-name)
    (match (assq-ref documentation configuration-name)
      ((fields . sub-documentation)
       `((deftp (% (category "Data Type") (name ,(str configuration-name)))
           (para "Available " (code ,(str configuration-name)) " fields are:")
           (table
            (% (formatter (asis)))
            ,@(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)
                         (package? val)
                         (and (symbol? val) (not (eq? val '%invalid)))
                         (and (list? val) (and-map show-default? val))))

                   (define (show-default val)
                     (cond
                      ((package? val)
                       (symbol->string (package->symbol val)))
                      (((list-of package?) val)
                       (format #f "(~{~a~^ ~})" (map package->symbol val)))
                      (else (str val))))

                   `(entry (% (heading
                               (code ,(str field-name))
                               ,@(if (show-default? default)
                                     `(" (default: "
                                       (code ,(show-default default)) ")")
                                     '())
                               " (type: " ,(str field-type) ")"))
                           (para ,@field-docs)
                           ,@(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))))

(define* (filter-configuration-fields configuration-fields fields
                                      #:optional negate?)
  "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS.
If NEGATE? is @code{#t}, retrieve all fields except FIELDS."
  (filter (lambda (field)
            (let ((member? (member (configuration-field-name field) fields)))
              (if (not negate?) member? (not member?))))
          configuration-fields))


(define* (interpose ls  #:optional (delimiter "\n") (grammar 'infix))
  "Same as @code{string-join}, but without join and string, returns a
DELIMITER interposed LS.  Support 'infix and 'suffix GRAMMAR values."
  (when (not (member grammar '(infix suffix)))
    (raise
     (formatted-message
      (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.")
      grammar)))
  (fold-right (lambda (e acc)
                (cons e
                      (if (and (null? acc) (eq? grammar 'infix))
                          acc
                          (cons delimiter acc))))
              '() ls))

(define (list-of pred?)
  "Return a procedure that takes a list and check if all the elements of
the list result in @code{#t} when applying PRED? on them."
    (lambda (x)
      (if (list? x)
          (every pred? x)
          #f)))


(define list-of-strings?
  (list-of string?))

(define alist?
  (list-of pair?))

(define serialize-file-like empty-serializer)

(define (text-config? config)
  (list-of file-like?))

(define (serialize-text-config field-name val)
  #~(string-append
     #$@(interpose
         (map
          (lambda (e)
            #~(begin
                (use-modules (ice-9 rdelim))
                (with-fluids ((%default-port-encoding "UTF-8"))
                  (with-input-from-file #$e read-string))))
          val)
         "\n" 'suffix)))

(define ((generic-serialize-alist-entry serialize-field) entry)
  "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY."
  (match entry
    ((field . val) (serialize-field field val))))

(define (generic-serialize-alist combine serialize-field fields)
  "Generate a configuration from an association list FIELDS.

SERIALIZE-FIELD is a procedure that takes two arguments, it will be
applied on the fields and values of FIELDS using the
@code{generic-serialize-alist-entry} procedure.

COMBINE is a procedure that takes one or more arguments and combines
all the alist entries into one value, @code{string-append} or
@code{append} are usually good candidates for this."
  (apply combine
         (map (generic-serialize-alist-entry serialize-field) fields)))