utils: Add json-file.

* modules/rosenthal/utils/file.scm (json-file): New procedure.
* modules/rosenthal/services/desktop.scm (%rosenthal-skeletons-installer)
[.cache/noctalia/shell-state.json]: Use it.

modules/rosenthal/services/child-error.scm

@@ -5,8 +5,8 @@
   ;; Utilities
   #:use-module (guix gexp)
   #:use-module (guix records)
+  #:use-module (rosenthal utils file)
   #:use-module (rosenthal utils predicates)
-  #:use-module (rosenthal utils serializers yaml)
   ;; Guix System
   #:use-module (gnu system shadow)
   ;; Guix System - services
@@ -274,16 +274,14 @@ headers.  This can expose sensitive information in your logs.")
    (file-like wakapi-bin)
    "The wakapi package.")
   (config
-   (yaml-config '())
+   gexp
    "Association list of Wakapi configurations.")
   (no-serialization))
 
 (define home-wakapi-shepherd-service
   (match-record-lambda <home-wakapi-configuration>
       (wakapi config)
-    (let ((config-file (mixed-text-file
-                        "wakapi.yaml"
-                        #~(string-append #$@(yaml-serialize config) "\n"))))
+    (let ((config-file (yaml-file "wakapi.yaml" config)))
       (list (shepherd-service
              (documentation "Run wakapi.")
              (provision '(wakapi))
@@ -299,7 +297,6 @@ headers.  This can expose sensitive information in your logs.")
    (extensions
     (list (service-extension home-shepherd-service-type
                              home-wakapi-shepherd-service)))
-   (default-value (home-wakapi-configuration))
    (description "Run Wakapi, a self-hosted WakaTime-compatible backend.")))
 
 

modules/rosenthal/services/desktop.scm

@@ -597,20 +597,12 @@ gtk-key-theme-name = ~a~%"
      ,(local-file "../examples/dot-config/wezterm/wezterm.lua"))
     ;; Prevent Noctalia shell initial screen.
     (".cache/noctalia/shell-state.json"
-     ,(computed-file "noctalia-shell-state.json"
-        (with-extensions (list guile-json-4)
-          #~(begin
-              (use-modules (json))
-              (call-with-output-file #$output
-                (lambda (port)
-                  (scm->json
-                   `(("changelogState"
-                      ("lastSeenVersion"
-                       . ,(string-append "v" #$(package-version noctalia-shell))))
-                     ("telemetry"
-                      ("instanceId" . "")))
-                   port
-                   #:pretty #t)))))))
+     ,(json-file "noctalia-shell-state.json"
+        #~'(("changelogState"
+             ("lastSeenVersion"
+              . #$(string-append "v" (package-version noctalia-shell))))
+            ("telemetry"
+             ("instanceId" . "")))))
     ,@%rosenthal-skeletons))
 
 

modules/rosenthal/services/mail.scm

@@ -7,7 +7,7 @@
   ;; Utilities
   #:use-module (guix gexp)
   #:use-module (guix records)
-  #:use-module (rosenthal utils serializers yaml)
+  #:use-module (rosenthal utils file)
   ;; Guix System - services
   #:use-module (gnu services)
   #:use-module (gnu services admin)
@@ -91,7 +91,7 @@
    (file-like goimapnotify)
    "")
   (config
-   yaml-config
+   gexp
    "")
   (wait
    (integer 1)
@@ -109,8 +109,7 @@
 (define home-goimapnotify-shepherd
   (match-record-lambda <home-goimapnotify-configuration>
       (goimapnotify config wait shepherd-provision shepherd-requirement auto-start?)
-    (let ((config-file
-           (mixed-text-file "goimapnotify.yaml" (yaml-serialize config))))
+    (let ((config-file (yaml-file "goimapnotify.yaml" config)))
       (list (shepherd-service
               (provision shepherd-provision)
               (requirement shepherd-requirement)

modules/rosenthal/services/monitoring.scm

@@ -6,9 +6,8 @@
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix records)
+  #:use-module (rosenthal utils file)
   #:use-module (rosenthal utils predicates)
-  #:use-module (rosenthal utils serializers ini)
-  #:use-module (rosenthal utils serializers yaml)
   ;; Guix System
   #:use-module (gnu system shadow)
   ;; Guix System - services
@@ -99,7 +98,7 @@
    (file-like grafana-bin)
    "")
   (config
-   ini-config
+   gexp
    "")
   (postgresql-password-file
    string
@@ -158,13 +157,7 @@
 (define grafana-shepherd
   (match-record-lambda <grafana-configuration>
       (grafana config shepherd-provision shepherd-requirement auto-start?)
-    (let ((config-file
-           (computed-file "grafana.ini"
-             (with-extensions (list guile-ini guile-lib guile-smc)
-               #~(begin
-                   (use-modules (srfi srfi-26) (ini))
-                   (call-with-output-file #$output
-                     (cut scm->ini '#$config #:port <>)))))))
+    (let ((config-file (ini-file "grafana.ini" config)))
       (list (shepherd-service
               (provision shepherd-provision)
               (requirement `(loopback postgresql user-processes
@@ -204,7 +197,7 @@
    (file-like loki-bin)
    "")
   (config
-   yaml-config
+   gexp
    "")
   (group-id
    (user-and-group-id #f)
@@ -251,16 +244,7 @@
 (define loki-shepherd
   (match-record-lambda <loki-configuration>
       (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))
@@ -297,7 +281,7 @@
    (file-like mimir-bin)
    "")
   (config
-   yaml-config
+   gexp
    "")
   (group-id
    (user-and-group-id #f)
@@ -344,16 +328,7 @@
 (define mimir-shepherd
   (match-record-lambda <mimir-configuration>
       (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))
@@ -393,7 +368,7 @@
    (string "0.0.0.0:9090")
    "")
   (config
-   yaml-config
+   gexp
    "")
   (group-id
    (user-and-group-id #f)
@@ -440,16 +415,7 @@
 (define prometheus-shepherd
   (match-record-lambda <prometheus-configuration>
       (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))

modules/rosenthal/services/web.scm

@@ -6,9 +6,8 @@
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix records)
+  #:use-module (rosenthal utils file)
   #:use-module (rosenthal utils predicates)
-  #:use-module (rosenthal utils serializers ini)
-  #:use-module (rosenthal utils serializers yaml)
   ;; Guix System
   #:use-module (gnu system privilege)
   #:use-module (gnu system shadow)
@@ -281,7 +280,7 @@ reload its configuration file."))
    (list-of-file-likes (list git git-lfs))
    "@code{git} and extension packages to install.")
   (config
-   ini-config
+   gexp
    "")
   (postgresql-password-file
    string
@@ -331,13 +330,7 @@ reload its configuration file."))
 (define forgejo-shepherd-service
   (match-record-lambda <forgejo-configuration>
       (forgejo config)
-    (let ((config-file
-           (computed-file "forgejo.ini"
-             (with-extensions (list guile-ini guile-lib guile-smc)
-               #~(begin
-                   (use-modules (srfi srfi-26) (ini))
-                   (call-with-output-file #$output
-                     (cut scm->ini '#$config #:port <>)))))))
+    (let ((config-file (ini-file "forgejo.ini" config)))
       (list (shepherd-service
               (documentation "Run Forgejo.")
               (provision '(forgejo))
@@ -650,7 +643,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")
@@ -698,16 +691,7 @@ test its configuration file."))
 (define misskey-oci
   (match-record-lambda <misskey-configuration>
       (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

modules/rosenthal/utils/file.scm

@@ -6,9 +6,16 @@
   #:use-module (ice-9 textual-ports)
   ;; Utilities
   #:use-module (guix gexp)
+  ;; Guix packages
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages guile-xyz)
   #:export (computed-substitution-with-inputs
             file-content
-            hidden-desktop-entry))
+            hidden-desktop-entry
+
+            ini-file
+            json-file
+            yaml-file))
 
 ;; XXX: ‘substitute*’ doesn't fully support Unicode:
 ;; https://codeberg.org/guix/guix/src/commit/a88d6a45e422cede96d57d7a953439dc27c6a50c/guix/build/utils.scm#L964
@@ -45,3 +52,44 @@
           (substitute* #$output
             (("^\\[Desktop Entry\\].*" all)
              (string-append all "NoDisplay=true\n")))))))
+
+
+;;;
+;;; Serializers.
+;;;
+
+;; https://github.com/artyom-poptsov/guile-ini
+(define (ini-file name exp)
+  "Return file-like object NAME, serialized from G-expression EXP in INI
+format."
+  (computed-file name
+    (with-extensions (list guile-ini guile-lib guile-smc)
+      #~(begin
+          (use-modules (srfi srfi-26) (ini))
+          (call-with-output-file #$output
+            (cut scm->ini #$exp #:port <>))))))
+
+;; https://github.com/aconchillo/guile-json
+(define (json-file name exp)
+  "Return file-like object NAME, serialized from G-expression EXP in JSON
+format."
+  (computed-file name
+    (with-extensions (list guile-json-4)
+      #~(begin
+          (use-modules (srfi srfi-26) (json))
+          (call-with-output-file #$output
+            (cut scm->json #$exp <> #:pretty #t))))))
+
+;; 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/ini.scm

@@ -1,154 +0,0 @@
-;;; SPDX-License-Identifier: GPL-3.0-or-later
-;;; Copyright © Copyright © 2022 Andrew Tropin <andrew@trop.in>
-
-(define-module (rosenthal utils serializers ini)
-  ;; Guile builtins
-  #:use-module (ice-9 format)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  ;; Utilities
-  #:use-module (guix diagnostics)
-  #:use-module (guix gexp)
-  #:use-module (guix packages)
-  #:use-module (guix ui)
-  #:use-module (rosenthal utils serializers)
-  ;; Guix System - services
-  #:use-module (gnu services configuration)
-  #:export (ini-serialize
-            ini-print
-            ini-merge
-            ini-append
-
-            serialize-ini-config
-            ini-config?))
-
-(define ini-config? list?)
-
-(define sample-ini
-  `((global ((daemon)
-             (log . file)))
-    (http ((host . 127.0.0.1)
-           (port . 1234)))))
-
-(define (format-ini-section section)
-  (match section
-    ('global "")
-    (name (format #f "[~a]\n" (symbol->string name)))))
-
-(define* (ini-serialize
-          config
-          #:key
-          (equal-string " = ")
-          (format-ini-section format-ini-section))
-  "For global properties use global section, the properties will be added to the
-beginning of the list before any section, this behavior can be adjusted with
-FORMAT-INI-SECTION argument.
-
-@lisp
-`((global ((daemon)
-           (log . file)))
-  (http ((host . 127.0.0.1)
-         (port . 1234))))
-@end lisp
-
-would yeld
-
-@example
-@end example
-"
-  (define (serialize-ini-term term)
-    (match term
-      (#t "true")
-      (#f "false")
-      ((? symbol? e) (symbol->string e))
-      ((? number? e) (number->string e))
-      ((? string? e) (object->string e))
-      ((lst ...)
-       (raise (formatted-message
-               (G_ "INI term should be a non-list value (string, \
-boolean, number, symbol, or gexp). Provided term is:\n ~a") lst)))
-      (e e)))
-
-  (define (serialize-ini-properties properties)
-     (unless (alist? properties)
-       (raise (formatted-message
-	       (G_ "INI properties should be an alist, \
-but provided value is:\n ~a") properties)))
-     (append-map
-      (match-lambda
-        ((? gexp? e)
-         (list e "\n"))
-        ((k)
-         (list (serialize-ini-term k) equal-string "\n"))
-        ((k . v)
-         (list (serialize-ini-term k) equal-string
-               (serialize-ini-term v) "\n")))
-      properties))
-
-  (define (serialize-ini-section section)
-    (match section
-      ((name properties)
-       (append
-        (list (format-ini-section name))
-        (serialize-ini-properties properties)))
-      (e
-       (raise (formatted-message
-               (G_ "INI section should be a list containing a section name as \
-the first element and alist of properties as the second, but provided value \
-is:\n~a") e)))))
-
-  ;; TODO: serialize global section before all other sections.
-  (append-map
-   (lambda (expr)
-     (append
-      (match expr
-        ((? gexp? e) (list e))
-        (e (serialize-ini-section e)))
-      (list "\n")))
-   config))
-
-(define (ini-merge ini1 ini2)
-  "Combine to INIs. Naive quadratic implementation, which can be rediculously
-slow."
-  (define keys-to-merge
-    (fold
-     (match-lambda*
-       (((k v) acc) (if (assoc-ref ini2 k) (cons k acc) acc))
-       (((? gexp? e) acc) acc))
-     '() ini1))
-
-  (define enriched-ini1
-    (fold-right
-     (match-lambda*
-       (((k v) acc)
-        (cons
-         (cons k (list (append v (car (or (assoc-ref ini2 k) '(()))))))
-         acc))
-       (((? gexp? e) acc) (cons e acc)))
-     '()
-     ini1))
-
-  (define stripped-ini2
-    (remove (match-lambda
-              ((k . v) (memq k keys-to-merge))
-              (e #f))
-            ini2))
-  (append enriched-ini1 stripped-ini2))
-
-(define (ini-append x acc)
-  (ini-merge acc x))
-
-(define serialize-ini-config ini-serialize)
-;; (display
-;;  (merge-ini
-;;   '((section1 ((k1 . v1)))
-;;     (section2 ((k4 . v4))))
-;;   '((section1 ((k2 . v2)
-;;                (k3 . v3)))
-;;     (section3 ((k5 . v5))))))
-
-;; (cdr '(a ((k . v) (k2 . v2))))
-
-(define (ini-print ini)
-  "Prints generated INI, useful for debugging."
-  (display (apply string-append (ini-serialize ini))))

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