diff --git a/modules/rosenthal/services/monitoring.scm b/modules/rosenthal/services/monitoring.scm index 000c2a8..6381185 100644 --- a/modules/rosenthal/services/monitoring.scm +++ b/modules/rosenthal/services/monitoring.scm @@ -198,7 +198,7 @@ (file-like loki-bin) "") (config - yaml-config + gexp "") (group-id (user-and-group-id #f) @@ -245,16 +245,7 @@ (define loki-shepherd (match-record-lambda (loki config shepherd-provision shepherd-requirement auto-start?) - (let ((config-file - (computed-file "loki.yaml" - (with-extensions (list guile-yamlpp) - #~(begin - (use-modules (yamlpp)) - (call-with-output-file #$output - (lambda (port) - (let ((emitter (make-yaml-emitter))) - (yaml-emit! emitter '#$config) - (display (yaml-emitter-string emitter) port))))))))) + (let ((config-file (yaml-file "loki.yaml" config))) (list (shepherd-service (provision shepherd-provision) (requirement `(loopback user-processes ,@shepherd-requirement)) @@ -291,7 +282,7 @@ (file-like mimir-bin) "") (config - yaml-config + gexp "") (group-id (user-and-group-id #f) @@ -338,16 +329,7 @@ (define mimir-shepherd (match-record-lambda (mimir config shepherd-provision shepherd-requirement auto-start?) - (let ((config-file - (computed-file "mimir.yaml" - (with-extensions (list guile-yamlpp) - #~(begin - (use-modules (yamlpp)) - (call-with-output-file #$output - (lambda (port) - (let ((emitter (make-yaml-emitter))) - (yaml-emit! emitter '#$config) - (display (yaml-emitter-string emitter) port))))))))) + (let ((config-file (yaml-file "mimir.yaml" config))) (list (shepherd-service (provision shepherd-provision) (requirement `(loopback user-processes ,@shepherd-requirement)) @@ -387,7 +369,7 @@ (string "0.0.0.0:9090") "") (config - yaml-config + gexp "") (group-id (user-and-group-id #f) @@ -434,16 +416,7 @@ (define prometheus-shepherd (match-record-lambda (prometheus listen-address config shepherd-provision shepherd-requirement auto-start?) - (let ((config-file - (computed-file "prometheus.yml" - (with-extensions (list guile-yamlpp) - #~(begin - (use-modules (yamlpp)) - (call-with-output-file #$output - (lambda (port) - (let ((emitter (make-yaml-emitter))) - (yaml-emit! emitter '#$config) - (display (yaml-emitter-string emitter) port))))))))) + (let ((config-file (yaml-file "prometheus.yml" config))) (list (shepherd-service (provision shepherd-provision) (requirement `(loopback user-processes ,@shepherd-requirement)) diff --git a/modules/rosenthal/services/web.scm b/modules/rosenthal/services/web.scm index 2d4753d..d9f7e0e 100644 --- a/modules/rosenthal/services/web.scm +++ b/modules/rosenthal/services/web.scm @@ -644,7 +644,7 @@ test its configuration file.")) (string "misskey/misskey:latest") "Misskey docker image to use.") (config - yaml-config + gexp "Alist of Misskey configuration, to be serialized to YAML format.") (data-directory (string "/var/lib/misskey") @@ -692,16 +692,7 @@ test its configuration file.")) (define misskey-oci (match-record-lambda (image config data-directory log-file ) - (let ((config-file - (computed-file "misskey.yaml" - (with-extensions (list guile-yamlpp) - #~(begin - (use-modules (yamlpp)) - (call-with-output-file #$output - (lambda (port) - (let ((emitter (make-yaml-emitter))) - (yaml-emit! emitter '#$config) - (display (yaml-emitter-string emitter) port))))))))) + (let ((config-file (yaml-file "misskey.yaml" config))) (oci-extension (containers (list (oci-container-configuration diff --git a/modules/rosenthal/utils/file.scm b/modules/rosenthal/utils/file.scm index 4f66056..5f5732d 100644 --- a/modules/rosenthal/utils/file.scm +++ b/modules/rosenthal/utils/file.scm @@ -12,7 +12,8 @@ file-content hidden-desktop-entry - ini-file)) + ini-file + yaml-file)) ;; XXX: ‘substitute*’ doesn't fully support Unicode: ;; https://codeberg.org/guix/guix/src/commit/a88d6a45e422cede96d57d7a953439dc27c6a50c/guix/build/utils.scm#L964 @@ -65,3 +66,17 @@ format." (use-modules (srfi srfi-26) (ini)) (call-with-output-file #$output (cut scm->ini #$exp #:port <>)))))) + +;; https://gitlab.com/yorgath/guile-yamlpp +(define (yaml-file name exp) + "Return file-like object NAME, serialized from G-expression EXP in YAML +format." + (computed-file name + (with-extensions (list guile-yamlpp) + #~(begin + (use-modules (yamlpp)) + (call-with-output-file #$output + (lambda (port) + (let ((emitter (make-yaml-emitter))) + (yaml-emit! emitter #$exp) + (display (yaml-emitter-string emitter) port)))))))) diff --git a/modules/rosenthal/utils/serializers.scm b/modules/rosenthal/utils/serializers.scm deleted file mode 100644 index ceb47a4..0000000 --- a/modules/rosenthal/utils/serializers.scm +++ /dev/null @@ -1,31 +0,0 @@ -;;; SPDX-License-Identifier: GPL-3.0-or-later -;;; Copyright © Copyright © 2022 Andrew Tropin - -(define-module (rosenthal utils serializers) - ;; Guile builtins - #:use-module (srfi srfi-1) - ;; Utilities - #:use-module (guix gexp) - ;; Guix System - services - #:use-module (gnu services configuration) - #:export (path? - serialize-path - - string-or-gexp? - serialize-string-or-gexp - - gexp-text-config? - serialize-gexp-text-config) - #:re-export (interpose)) - -(define path? string?) -(define (serialize-path field-name val) val) - -(define (string-or-gexp? sg) (or (string? sg) (gexp? sg))) -(define (serialize-string-or-gexp field-name val) "") - -;; Guix proper has a different version of text-config. -(define (gexp-text-config? config) - (and (list? config) (every string-or-gexp? config))) -(define (serialize-gexp-text-config field-name val) - #~(string-append #$@(interpose val "\n" 'suffix))) diff --git a/modules/rosenthal/utils/serializers/yaml.scm b/modules/rosenthal/utils/serializers/yaml.scm deleted file mode 100644 index 51b5951..0000000 --- a/modules/rosenthal/utils/serializers/yaml.scm +++ /dev/null @@ -1,156 +0,0 @@ -;;; SPDX-License-Identifier: GPL-3.0-or-later -;;; Copyright © Copyright © 2023 Miguel Ángel Moreno - -(define-module (rosenthal utils serializers yaml) - ;; Guile builtins - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-43) - ;; Utilities - #:use-module (guix diagnostics) - #:use-module (guix gexp) - #:use-module (guix ui) - #:use-module (rosenthal utils serializers) - ;; Guix System - services - #:use-module (gnu services configuration) - ;; Guix Home - services - #:use-module (gnu home services utils) - #:export (yaml-print - yaml-config? - yaml-serialize - - serialize-yaml-term - serialize-yaml-element - serialize-yaml-config)) - -(define yaml-config? list?) - -(define (yaml-term? t) - (fold (lambda (x acc) (or acc (x t))) - #f - (list boolean? symbol? number? string? file-like? gexp?))) - -(define (serialize-yaml-string v) - (format #f "~s" v)) - -(define (serialize-yaml-symbol v) - (format #f "~a" v)) - -(define (serialize-yaml-term term) - (match term - ((? boolean? v) (if v "true" "false")) - ((? number? v) (number->string v)) - ((? string? v) (serialize-yaml-string v)) - ((? symbol? v) (serialize-yaml-symbol v)) - ((or (? gexp? v) - (? file-like? v)) - v) - (v (raise (formatted-message - (G_ "\ -YAML term should be boolean, number, string, symbol, or gexp. Provided term -is:\n ~a") v))))) - -(define (serialize-yaml-key k) - (list - (cond - ((symbol? k) (serialize-yaml-symbol k)) - ((string? k) (serialize-yaml-string k)) - (else (raise (formatted-message - (G_ "\ -YAML key should be symbol or string. Provided key is:\n ~a") - k)))))) - -(define (serialize-yaml-newline pretty?) - (if pretty? (list "\n") '())) - -(define (serialize-yaml-space pretty?) - (if pretty? (list " ") '())) - -(define (serialize-yaml-indentation level pretty?) - (if pretty? - (list (format #f "~v_" (- (* 2 level) 2))) - '())) - -(define (serialize-yaml-vector v level pretty?) - (append - (serialize-yaml-newline pretty?) - (vector-fold - (lambda (i acc e) - (append acc - (if (> i 0) - (serialize-yaml-newline pretty?) - '()) - (serialize-yaml-indentation (1+ level) pretty?) - (list "- ") - (match e - ((? alist? e) - (serialize-yaml-vector-alist e (+ 1 level) pretty?)) - (_ (serialize-yaml-element e (1+ level) pretty?))))) - '() v))) - -(define (serialize-yaml-list v pretty?) - (append - (list "[") - (interpose - (append-map - (lambda (x) - (serialize-yaml-element x 0 pretty?)) - v) - ", ") - (list "]"))) - -(define (serialize-yaml-pair v level pretty?) - (append - (serialize-yaml-indentation level pretty?) - (serialize-yaml-key (car v)) - (list ":") - (serialize-yaml-space pretty?) - (if (alist? (cdr v)) - (serialize-yaml-newline pretty?) - (list "")) - (serialize-yaml-element (cdr v) level pretty?))) - -(define (serialize-yaml-alist v level pretty?) - (append - (serialize-yaml-pair (car v) (1+ level) pretty?) - (append-map - (lambda (x) - (append - (serialize-yaml-newline pretty?) - (serialize-yaml-pair x (1+ level) pretty?))) - (cdr v)))) - -(define (serialize-yaml-vector-alist v level pretty?) - (append - (serialize-yaml-pair (car v) (- level (- level 1)) pretty?) - (append-map - (lambda (x) - (append - (serialize-yaml-newline pretty?) - (serialize-yaml-pair x (1+ level) pretty?))) - (cdr v)))) - -(define (serialize-yaml-element yaml level pretty?) - (append - (match yaml - (() (list "")) - ((? yaml-term? v) (list (serialize-yaml-term v))) - ((? alist? v) (serialize-yaml-alist v level pretty?)) - ((? list? v) (serialize-yaml-list v pretty?)) - ((? vector? v) (serialize-yaml-vector v level pretty?)) - (e (throw 'yaml-invalid yaml))))) - -(define (serialize-yaml-config f c) - #~(apply string-append - (list #$@(serialize-yaml-element c 0 #t)))) - -(define* (yaml-serialize config) - "Returns a list of YAML strings which have to be concatenated. It supports - gexps, file-likes, vectors -> arrays, alists -> dictionaries, etc." - (serialize-yaml-config #f config)) - -(define* (yaml-print yaml #:key (pretty? #t)) - "Prints the generated YAML, useful for debugging purposes." - (display (apply string-append - (serialize-yaml-element yaml 0 pretty?))))