utils: Add yaml-file.

* modules/rosenthal/utils/file.scm (yaml-file): New procedure.
* modules/rosenthal/services/monitoring.scm (loki-shepherd, mimir-shepherd)
(prometheus-shepherd)
* modules/rosenthal/services/web.scm (misskey-oci): Use it.
* modules/rosenthal/utils/serializers.scm
* modules/rosenthal/utils/serializers/yaml.scm: Delete modules.

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-configuration>
       (loki config shepherd-provision shepherd-requirement auto-start?)
-    (let ((config-file
+    (let ((config-file (yaml-file "loki.yaml" config)))
-           (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)))))))))
       (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-configuration>
       (mimir config shepherd-provision shepherd-requirement auto-start?)
-    (let ((config-file
+    (let ((config-file (yaml-file "mimir.yaml" config)))
-           (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)))))))))
       (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-configuration>
       (prometheus listen-address config shepherd-provision shepherd-requirement auto-start?)
-    (let ((config-file
+    (let ((config-file (yaml-file "prometheus.yml" config)))
-           (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)))))))))
       (list (shepherd-service
               (provision shepherd-provision)
               (requirement `(loopback user-processes ,@shepherd-requirement))

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 <misskey-configuration>
       (image config data-directory log-file )
-    (let ((config-file
+    (let ((config-file (yaml-file "misskey.yaml" config)))
-           (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)))))))))
       (oci-extension
         (containers
          (list (oci-container-configuration

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))))))))

modules/rosenthal/utils/serializers.scm

@@ -1,31 +0,0 @@
-;;; SPDX-License-Identifier: GPL-3.0-or-later
-;;; Copyright © Copyright © 2022 Andrew Tropin <andrew@trop.in>
-
-(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)))

modules/rosenthal/utils/serializers/yaml.scm

@@ -1,156 +0,0 @@
-;;; SPDX-License-Identifier: GPL-3.0-or-later
-;;; Copyright © Copyright © 2023 Miguel Ángel Moreno <mail@migalmoreno.com>
-
-(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?))))