;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Ludovic Courtès ;;; Copyright © 2016, 2017 Kei Kebreau ;;; Copyright © 2018 Tobias Geerinckx-Rice ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2022 Zhu Zihao ;;; ;;; 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
aboutsummaryrefslogtreecommitdiff
;;; 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>
;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
;;;
;;; 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)
  #:use-module (srfi srfi-171)
  #: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

            empty-serializer?
            tfilter-maybe-value
            base-transducer

            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-packages?
            list-of-strings?
            list-of-symbols?
            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 (empty-serializer? field)
  "Predicate that checks whether FIELD is exempt from serialization."
  (eq? empty-serializer
       (configuration-field-serializer field)))

(define (tfilter-maybe-value config)
  "Return a transducer for CONFIG that removes all maybe-type fields whose
value is '%unset-marker."
  (tfilter (lambda (field)
             (let ((field-value ((configuration-field-getter field) config)))
               (maybe-value-set? field-value)))))

(define (base-transducer config)
  "Return a transducer for CONFIG that calls the serializing procedures only
for fields marked for serialization and whose values are not '%unset-marker."
  (compose (tremove empty-serializer?)
           ;; Only serialize fields whose value isn't '%unset-marker%.
           (tfilter-maybe-value config)
           (tmap (lambda (field)
                   ((configuration-field-serializer field)
                    (configuration-field-name field)
                    ((configuration-field-getter field) config))))))

(define (serialize-configuration config fields)
  "Return a G-expression that contains the values corresponding to the
FIELDS of CONFIG, a record that has been generated by `define-configuration'.
The G-expression can then be serialized to disk by using something like
`mixed-text-file'."
  #~(string-append
     #$@(list-transduce (base-transducer config) rcons 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* #f)
               (serializer* #f))
      (syntax-case s (sanitizer serializer empty-serializer)
        (((sanitizer proc) tail ...)
         (if sanitizer*
             (syntax-violation 'sanitizer
                               "duplicate entry" #'proc)
             (loop #'(tail ...) #'proc serializer*)))
        (((serializer proc) tail ...)
         (if serializer*
             (syntax-violation 'serializer
                               "duplicate or conflicting entry" #'proc)
             (loop #'(tail ...) sanitizer* #'proc)))
        ((empty-serializer tail ...)
         (if 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.
         (not (or sanitizer* serializer*))
         (begin
           (warning #f (G_ "specifying serializers after documentation is \
deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
           (values (list #f #'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 ...)
             #'(sanitizer* ...))
            ((field-serializer ...)
             (map (lambda (type proc)
                    (and serialize?
                         (or 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