Merge branch 'master' into core-updates

Change-Id: Iea8f10db98256f1c6cfac8bfcc82e2d44695ef3d

15 files changed, 549 insertions, 101 deletions

diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm
index 5cf74c6e4d..0b325fddb1 100644
--- a/gnu/services/admin.scm
+++ b/gnu/services/admin.scm
@@ -52,6 +52,10 @@
 
             rottlog-configuration
             rottlog-configuration?
+            rottlog-configuration-rottlog
+            rottlog-configuration-rc-file
+            rottlog-configuration-rotations
+            rottlog-configuration-jobs
             rottlog-service
             rottlog-service-type
 
@@ -193,25 +197,25 @@ for ROTATION."
 (define-record-type* <rottlog-configuration>
   rottlog-configuration make-rottlog-configuration
   rottlog-configuration?
-  (rottlog            rottlog-rottlog             ;file-like
+  (rottlog            rottlog-configuration-rottlog             ;file-like
                       (default rottlog))
-  (rc-file            rottlog-rc-file             ;file-like
+  (rc-file            rottlog-configuration-rc-file             ;file-like
                       (default (file-append rottlog "/etc/rc")))
-  (rotations          rottlog-rotations           ;list of <log-rotation>
+  (rotations          rottlog-configuration-rotations           ;list of <log-rotation>
                       (default %default-rotations))
-  (jobs               rottlog-jobs                ;list of <mcron-job>
+  (jobs               rottlog-configuration-jobs                ;list of <mcron-job>
                       (default #f)))
 
 (define (rottlog-etc config)
   `(("rottlog"
      ,(file-union "rottlog"
-                  (cons `("rc" ,(rottlog-rc-file config))
+                  (cons `("rc" ,(rottlog-configuration-rc-file config))
                         (log-rotations->/etc-entries
-                         (rottlog-rotations config)))))))
+                         (rottlog-configuration-rotations config)))))))
 
 (define (rottlog-jobs-or-default config)
-  (or (rottlog-jobs config)
-      (default-jobs (rottlog-rottlog config))))
+  (or (rottlog-configuration-jobs config)
+      (default-jobs (rottlog-configuration-rottlog config))))
 
 (define rottlog-service-type
   (service-type
@@ -226,12 +230,12 @@ Old log files are removed or compressed according to the configuration.")
                      ;; Add Rottlog to the global profile so users can access
                      ;; the documentation.
                      (service-extension profile-service-type
-                                        (compose list rottlog-rottlog))))
+                                        (compose list rottlog-configuration-rottlog))))
    (compose concatenate)
    (extend (lambda (config rotations)
              (rottlog-configuration
               (inherit config)
-              (rotations (append (rottlog-rotations config)
+              (rotations (append (rottlog-configuration-rotations config)
                                  rotations)))))
    (default-value (rottlog-configuration))))
 
diff --git a/gnu/services/audio.scm b/gnu/services/audio.scm
index 260abdefed..ae991ced4d 100644
--- a/gnu/services/audio.scm
+++ b/gnu/services/audio.scm
@@ -138,9 +138,6 @@
                                    str)
                                #\-) "_")))
 
-(define list-of-symbol?
-  (list-of symbol?))
-
 ;; Helpers for deprecated field types, to be removed later.
 (define %lazy-group (make-symbol "%lazy-group"))
 
@@ -428,7 +425,7 @@ to be appended to the audio output configuration.")
    (sanitizer mpd-group-sanitizer))
 
   (shepherd-requirement
-   (list-of-symbol '())
+   (list-of-symbols '())
    "This is a list of symbols naming Shepherd services that this service
 will depend on."
    empty-serializer)
@@ -763,7 +760,7 @@ user-group instead~%"))
     empty-serializer)
 
   (shepherd-requirement
-   (list-of-symbol '())
+   (list-of-symbols '())
    "This is a list of symbols naming Shepherd services that this service
 will depend on."
    empty-serializer)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 98d59fd36d..dc001fdef6 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -63,7 +63,9 @@
   #:use-module (gnu packages bash)
   #:use-module ((gnu packages base)
                 #:select (coreutils glibc glibc/hurd
-                          glibc-utf8-locales make-glibc-utf8-locales
+                          glibc-utf8-locales
+                          libc-utf8-locales-for-target
+                          make-glibc-utf8-locales
                           tar canonical-package))
   #:use-module ((gnu packages compression) #:select (gzip))
   #:use-module (gnu packages fonts)
@@ -2147,7 +2149,8 @@ raise a deprecation warning if the 'compression-level' field was used."
                       ;; nars for packages that contain UTF-8 file names such
                       ;; as 'nss-certs'.  See <https://bugs.gnu.org/26948>.
                       (list (string-append "GUIX_LOCPATH="
-                                           #$glibc-utf8-locales "/lib/locale")
+                                           #$(libc-utf8-locales-for-target)
+                                           "/lib/locale")
                             "LC_ALL=en_US.utf8")
                       #:log-file "/var/log/guix-publish.log"))
           (endpoints #~(let ((ai (false-if-exception
@@ -2692,6 +2695,33 @@ Write, say, @samp{\"~a/24\"} for a 24-bit network mask.")
                                 address)))))))
   address)
 
+(define (mac-address? str)
+  "Return true if STR is a valid MAC address."
+  (let ((pattern (make-regexp "^([0-9A-Fa-f]{2}:?){6}$")))
+    (false-if-exception (vector? (regexp-exec pattern str)))))
+
+(define-compile-time-procedure (assert-network-link-mac-address (value identity))
+  (cond
+   ((eq? value #f) value)
+   ((and (string? value) (mac-address? value)) value)
+   (else (raise
+          (make-compound-condition
+           (formatted-message (G_ "Value (~S) is not a valid mac address.~%")
+                              value)
+           (condition (&error-location
+                       (location (source-properties->location procedure-call-location)))))))))
+
+(define-compile-time-procedure (assert-network-link-type (value identity))
+  (match value
+    (#f value)
+    (('quote _) (datum->syntax #'value value))
+    (else
+     (raise
+      (make-compound-condition
+       (formatted-message (G_ "Value (~S) is not a symbol.~%") value)
+       (condition (&error-location
+                   (location (source-properties->location procedure-call-location)))))))))
+
 (define-record-type* <static-networking>
   static-networking make-static-networking
   static-networking?
@@ -2719,8 +2749,14 @@ Write, say, @samp{\"~a/24\"} for a 24-bit network mask.")
 (define-record-type* <network-link>
   network-link make-network-link
   network-link?
-  (name      network-link-name)                   ;string--e.g, "v0p0"
-  (type      network-link-type)                   ;symbol--e.g.,'veth
+  (name      network-link-name
+             (default #f))                   ;string or #f --e.g, "v0p0"
+  (type      network-link-type
+             (sanitize assert-network-link-type)
+             (default #f))                   ;symbol or #f--e.g.,'veth, 'bond
+  (mac-address network-link-mac-address
+               (sanitize assert-network-link-mac-address)
+               (default #f))
   (arguments network-link-arguments))             ;list
 
 (define-record-type* <network-route>
@@ -2845,7 +2881,77 @@ to CONFIG."
     (scheme-file "set-up-network"
                  (with-extensions (list guile-netlink)
                    #~(begin
-                       (use-modules (ip addr) (ip link) (ip route))
+                       (use-modules (ip addr) (ip link) (ip route)
+                                    (srfi srfi-1)
+                                    (ice-9 format)
+                                    (ice-9 match))
+
+                       (define (match-link-by field-accessor value)
+                         (fold (lambda (link result)
+                                 (if (equal? (field-accessor link) value)
+                                     link
+                                     result))
+                               #f
+                               (get-links)))
+
+                       (define (alist->keyword+value alist)
+                         (fold (match-lambda*
+                                 (((k . v) r)
+                                  (cons* (symbol->keyword k) v r))) '() alist))
+
+                       ;; FIXME: It is interesting that "modprobe bonding" creates an
+                       ;; interface bond0 straigt away.  If we won't have bonding
+                       ;; module, and execute `ip link add name bond0 type bond' we
+                       ;; will get
+                       ;;
+                       ;; RTNETLINK answers: File exists
+                       ;;
+                       ;; This breaks our configuration if we want to
+                       ;; use `bond0' name.  Create (force modprobe
+                       ;; bonding) and delete the interface to free up
+                       ;; bond0 name.
+                       #$(let lp ((links links))
+                           (cond
+                            ((null? links) #f)
+                            ((and (network-link? (car links))
+                                  ;; Type is not mandatory
+                                  (false-if-exception
+                                   (eq? (network-link-type (car links)) 'bond)))
+                             #~(begin
+                                 (false-if-exception (link-add "bond0" "bond"))
+                                 (link-del "bond0")))
+                            (else (lp (cdr links)))))
+
+                       #$@(map (match-lambda
+                                 (($ <network-link> name type mac-address arguments)
+                                  (cond
+                                   ;; Create a new interface
+                                   ((and (string? name) (symbol? type))
+                                    #~(begin
+                                        (link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
+                                        ;; XXX: If we add routes, addresses must be
+                                        ;; already assigned, and interfaces must be
+                                        ;; up. It doesn't matter if they won't have
+                                        ;; carrier or anything.
+                                        (link-set #$name #:up #t)))
+
+                                   ;; Amend an existing interface
+                                   ((and (string? name)
+                                         (eq? type #f))
+                                    #~(let ((link (match-link-by link-name #$name)))
+                                        (if link
+                                            (apply link-set
+                                                   (link-id link)
+                                                   (alist->keyword+value '#$arguments))
+                                            (format #t (G_ "Interface with name '~a' not found~%") #$name))))
+                                   ((string? mac-address)
+                                    #~(let ((link (match-link-by link-addr #$mac-address)))
+                                        (if link
+                                            (apply link-set
+                                                   (link-id link)
+                                                   (alist->keyword+value '#$arguments))
+                                            (format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
+                                        links)
 
                        #$@(map (lambda (address)
                                  #~(begin
@@ -2864,11 +2970,7 @@ to CONFIG."
                                                #:multicast-on #t
                                                #:up #t)))
                                addresses)
-                       #$@(map (match-lambda
-                                 (($ <network-link> name type arguments)
-                                  #~(link-add #$name #$type
-                                              #:type-args '#$arguments)))
-                               links)
+
                        #$@(map (lambda (route)
                                  #~(route-add #$(network-route-destination route)
                                               #:device
@@ -2912,11 +3014,9 @@ to CONFIG."
                                                #:src
                                                #$(network-route-source route))))
                                routes)
-                       #$@(map (match-lambda
-                                 (($ <network-link> name type arguments)
-                                  #~(false-if-netlink-error
-                                     (link-del #$name))))
-                               links)
+
+                       ;; Cleanup addresses first, they might be assigned to
+                       ;; created bonds, vlans or bridges.
                        #$@(map (lambda (address)
                                  #~(false-if-netlink-error
                                     (addr-del #$(network-address-device
@@ -2925,6 +3025,17 @@ to CONFIG."
                                               #:ipv6?
                                               #$(network-address-ipv6? address))))
                                addresses)
+
+                       ;; It is now safe to delete some links
+                       #$@(map (match-lambda
+                                 (($ <network-link> name type mac-address arguments)
+                                  (cond
+                                   ;; We delete interfaces that were created
+                                   ((and (string? name) (symbol? type))
+                                    #~(false-if-netlink-error
+                                       (link-del #$name)))
+                                   (else #t))))
+                               links)
                        #f)))))
 
 (define (static-networking-shepherd-service config)
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 367b85c1be..d2b1687496 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -42,6 +42,7 @@
   #: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
@@ -59,6 +60,10 @@
             define-configuration/no-serialization
             no-serialization
 
+            empty-serializer?
+            tfilter-maybe-value
+            base-transducer
+
             serialize-configuration
             define-maybe
             define-maybe/no-serialization
@@ -75,7 +80,9 @@
             interpose
             list-of
 
+            list-of-packages?
             list-of-strings?
+            list-of-symbols?
             alist?
             serialize-file-like
             text-config?
@@ -125,13 +132,36 @@ does not have a default value" field kind)))
   (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
-     #$@(map (lambda (field)
-               ((configuration-field-serializer field)
-                (configuration-field-name field)
-                ((configuration-field-getter field) config)))
-             fields)))
+     #$@(list-transduce (base-transducer config) rcons fields)))
 
 (define-syntax-rule (id ctx parts ...)
   "Assemble PARTS into a raw (unhygienic) identifier."
@@ -190,32 +220,32 @@ does not have a default value" field kind)))
   (define (normalize-extra-args s)
     "Extract and normalize arguments following @var{doc}."
     (let loop ((s s)
-               (sanitizer* %unset-value)
-               (serializer* %unset-value))
+               (sanitizer* #f)
+               (serializer* #f))
       (syntax-case s (sanitizer serializer empty-serializer)
         (((sanitizer proc) tail ...)
-         (if (maybe-value-set? sanitizer*)
-             (syntax-violation 'sanitizer "duplicate entry"
-                               #'proc)
+         (if 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)
+         (if serializer*
+             (syntax-violation 'serializer
+                               "duplicate or conflicting entry" #'proc)
              (loop #'(tail ...) sanitizer* #'proc)))
         ((empty-serializer tail ...)
-         (if (maybe-value-set? serializer*)
+         (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.
-         (null? (filter-map maybe-value-set? (list sanitizer* serializer*)))
+         (not (or sanitizer* serializer*))
          (begin
            (warning #f (G_ "specifying serializers after documentation is \
 deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
-           (values (list %unset-value #'proc)))))))
+           (values (list #f #'proc)))))))
 
   (syntax-case syn ()
     ((_ stem (field field-type+def doc extra-args ...) ...)
@@ -239,11 +269,11 @@ deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
                      default-value))
                   #'((field-type def) ...)))
             ((field-sanitizer ...)
-             (map maybe-value #'(sanitizer* ...)))
+             #'(sanitizer* ...))
             ((field-serializer ...)
              (map (lambda (type proc)
                     (and serialize?
-                         (or (maybe-value proc)
+                         (or proc
                              (if serializer-prefix
                                  (id #'stem serializer-prefix #'serialize- type)
                                  (id #'stem #'serialize- type)))))
@@ -472,6 +502,11 @@ DELIMITER interposed LS.  Support 'infix and 'suffix GRAMMAR values."
                           (cons delimiter acc))))
               '() ls))
 
+
+;;;
+;;; Commonly used predicates
+;;;
+
 (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."
@@ -480,10 +515,20 @@ the list result in @code{#t} when applying PRED? on them."
           (every pred? x)
           #f)))
 
+(define list-of-packages?
+  (list-of package?))
 
 (define list-of-strings?
   (list-of string?))
 
+(define list-of-symbols?
+  (list-of symbol?))
+
+
+;;;
+;;; Special serializers
+;;;
+
 (define alist?
   (list-of pair?))
 
diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
index 71787a85e6..fcbd5e08a5 100644
--- a/gnu/services/cuirass.scm
+++ b/gnu/services/cuirass.scm
@@ -73,6 +73,8 @@
                     (default "/var/log/cuirass-remote-server.log"))
   (cache            cuirass-remote-server-configuration-cache ;string
                     (default "/var/cache/cuirass/remote/"))
+  (log-expiry       cuirass-remote-server-configuration-log-expiry
+                    (default (* 6 30 24 3600)))   ;6 months
   (publish?         cuirass-remote-server-configuration-publish? ;boolean
                     (default #t))
   (trigger-url      cuirass-remote-server-trigger-url ;string
@@ -194,7 +196,7 @@
         (stop #~(make-kill-destructor)))
       ,@(if remote-server
             (match-record remote-server <cuirass-remote-server-configuration>
-              (backend-port publish-port log-file cache publish?
+              (backend-port publish-port log-file log-expiry cache publish?
                             trigger-url public-key private-key)
               (list
                (shepherd-service
@@ -207,6 +209,9 @@
                                 (string-append "--database=" #$database)
                                 (string-append "--cache=" #$cache)
                                 (string-append "--user=" #$user)
+                                (string-append "--log-expiry="
+                                               #$(number->string log-expiry)
+                                               "s")
                                 #$@(if backend-port
                                        (list (string-append
                                               "--backend-port="
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index c2023d618c..ebea0a473a 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,15 +30,36 @@
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
+  #:use-module (gnu packages admin)               ;shadow
   #:use-module (gnu packages docker)
   #:use-module (gnu packages linux)               ;singularity
   #:use-module (guix records)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
   #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
 
   #:export (docker-configuration
             docker-service-type
-            singularity-service-type))
+            singularity-service-type
+            oci-container-configuration
+            oci-container-configuration?
+            oci-container-configuration-fields
+            oci-container-configuration-user
+            oci-container-configuration-group
+            oci-container-configuration-command
+            oci-container-configuration-entrypoint
+            oci-container-configuration-environment
+            oci-container-configuration-image
+            oci-container-configuration-provision
+            oci-container-configuration-network
+            oci-container-configuration-ports
+            oci-container-configuration-volumes
+            oci-container-service-type
+            oci-container-shepherd-service))
 
 (define-configuration docker-configuration
   (docker
@@ -216,3 +238,239 @@ bundles in Docker containers.")
                        (service-extension activation-service-type
                                           (const %singularity-activation))))
                 (default-value singularity)))
+
+
+;;;
+;;; OCI container.
+;;;
+
+(define (oci-sanitize-pair pair delimiter)
+  (define (valid? member)
+    (or (string? member)
+        (gexp? member)
+        (file-like? member)))
+  (match pair
+    (((? valid? key) . (? valid? value))
+     #~(string-append #$key #$delimiter #$value))
+    (_
+     (raise
+      (formatted-message
+       (G_ "pair members must contain only strings, gexps or file-like objects
+but ~a was found")
+       pair)))))
+
+(define (oci-sanitize-mixed-list name value delimiter)
+  (map
+   (lambda (el)
+     (cond ((string? el) el)
+           ((pair? el) (oci-sanitize-pair el delimiter))
+           (else
+            (raise
+             (formatted-message
+              (G_ "~a members must be either a string or a pair but ~a was
+found!")
+              name el)))))
+   value))
+
+(define (oci-sanitize-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "environment" value "="))
+
+(define (oci-sanitize-ports value)
+  ;; Expected spec format:
+  ;; '(("8088" . "80") "2022:22")
+  (oci-sanitize-mixed-list "ports" value ":"))
+
+(define (oci-sanitize-volumes value)
+  ;; Expected spec format:
+  ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
+  (oci-sanitize-mixed-list "volumes" value ":"))
+
+(define-maybe/no-serialization string)
+
+(define-configuration/no-serialization oci-container-configuration
+  (user
+   (string "oci-container")
+   "The user under whose authority docker commands will be run.")
+  (group
+   (string "docker")
+   "The group under whose authority docker commands will be run.")
+  (command
+   (list-of-strings '())
+   "Overwrite the default command (@code{CMD}) of the image.")
+  (entrypoint
+   (maybe-string)
+   "Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.")
+  (environment
+   (list '())
+   "Set environment variables.  This can be a list of pairs or strings, even
+mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+      \"JAVA_HOME=/opt/java\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-environment))
+  (image
+   (string)
+   "The image used to build the container.  Images are resolved by the Docker
+Engine, and follow the usual format
+@code{myregistry.local:5000/testing/test-image:tag}.")
+  (provision
+   (maybe-string)
+   "Set the name of the provisioned Shepherd service.")
+  (network
+   (maybe-string)
+   "Set a Docker network for the spawned container.")
+  (ports
+   (list '())
+   "Set the port or port ranges to expose from the spawned container.  This can
+be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"8080\" . \"80\")
+      \"10443:443\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-ports))
+  (volumes
+   (list '())
+   "Set volume mappings for the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"/root/data/grafana\" . \"/var/lib/grafana\")
+      \"/gnu/store:/gnu/store\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-volumes))
+  (container-user
+   (maybe-string)
+   "Set the current user inside the spawned container.  You can refer to the
+@url{https://docs.docker.com/engine/reference/run/#user,upstream}
+documentation for semantics.")
+  (workdir
+   (maybe-string)
+   "Set the current working for the spawned Shepherd service.
+You can refer to the
+@url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
+documentation for semantics."))
+
+(define oci-container-configuration->options
+  (lambda (config)
+    (let ((entrypoint
+           (oci-container-configuration-entrypoint config))
+          (network
+           (oci-container-configuration-network config))
+          (user
+           (oci-container-configuration-user config))
+          (workdir
+           (oci-container-configuration-workdir config)))
+      (apply append
+             (filter (compose not unspecified?)
+                     `(,(if (maybe-value-set? entrypoint)
+                            `("--entrypoint" ,entrypoint)
+                            '())
+                       ,(append-map
+                         (lambda (spec)
+                           (list "--env" spec))
+                         (oci-container-configuration-environment config))
+                       ,(if (maybe-value-set? network)
+                            `("--network" ,network)
+                            '())
+                       ,(if (maybe-value-set? user)
+                            `("--user" ,user)
+                            '())
+                       ,(if (maybe-value-set? workdir)
+                            `("--workdir" ,workdir)
+                            '())
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-p" spec))
+                         (oci-container-configuration-ports config))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-v" spec))
+                         (oci-container-configuration-volumes config))))))))
+
+(define (oci-container-shepherd-service config)
+  (define (guess-name name image)
+    (if (maybe-value-set? name)
+        name
+        (string-append "docker-"
+                       (basename (car (string-split image #\:))))))
+
+  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+         (user (oci-container-configuration-user config))
+         (group (oci-container-configuration-group config))
+         (command (oci-container-configuration-command config))
+         (provision (oci-container-configuration-provision config))
+         (image (oci-container-configuration-image config))
+         (options (oci-container-configuration->options config))
+         (name (guess-name provision image)))
+
+    (shepherd-service (provision `(,(string->symbol name)))
+                      (requirement '(dockerd user-processes))
+                      (respawn? #f)
+                      (documentation
+                       (string-append
+                        "Docker backed Shepherd service for image: " image))
+                      (start
+                       #~(make-forkexec-constructor
+                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                          (list #$docker-command "run" "--rm"
+                                "--name" #$name
+                                #$@options #$image #$@command)
+                          #:user #$user
+                          #:group #$group))
+                      (stop
+                       #~(lambda _
+                           (invoke #$docker-command "rm" "-f" #$name)))
+                      (actions
+                       (list
+                        (shepherd-action
+                         (name 'pull)
+                         (documentation
+                          (format #f "Pull ~a's image (~a)."
+                                  name image))
+                         (procedure
+                          #~(lambda _
+                              (invoke #$docker-command "pull" #$image)))))))))
+
+(define %oci-container-accounts
+  (list (user-account
+         (name "oci-container")
+         (comment "OCI services account")
+         (group "docker")
+         (system? #t)
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define (configs->shepherd-services configs)
+  (map oci-container-shepherd-service configs))
+
+(define oci-container-service-type
+  (service-type (name 'oci-container)
+                (extensions (list (service-extension profile-service-type
+                                                     (lambda _ (list docker-cli)))
+                                  (service-extension account-service-type
+                                                     (const %oci-container-accounts))
+                                  (service-extension shepherd-root-service-type
+                                                     configs->shepherd-services)))
+                (default-value '())
+                (extend append)
+                (compose concatenate)
+                (description
+                 "This service allows the management of Docker and OCI
+containers as Shepherd services.")))
diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm
index fe602efb99..389903451a 100644
--- a/gnu/services/guix.scm
+++ b/gnu/services/guix.scm
@@ -23,7 +23,7 @@
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module ((gnu packages base)
-                #:select (glibc-utf8-locales))
+                #:select (libc-utf8-locales-for-target))
   #:use-module (gnu packages admin)
   #:use-module (gnu packages databases)
   #:use-module (gnu packages web)
@@ -381,7 +381,8 @@
                      #:pid-file-timeout 60
                      #:environment-variables
                      `(,(string-append
-                         "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
+                         "GUIX_LOCPATH="
+                         #$(libc-utf8-locales-for-target) "/lib/locale")
                        "LC_ALL=en_US.utf8"
                        "PATH=/run/current-system/profile/bin" ; for hooks
                        #$@extra-environment-variables)
@@ -508,7 +509,8 @@
               #:user #$user
               #:environment-variables
               `(,(string-append
-                  "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
+                  "GUIX_LOCPATH="
+                  #$(libc-utf8-locales-for-target) "/lib/locale")
                 ;; XDG_CACHE_HOME is used by Guix when caching narinfo files
                 "XDG_CACHE_HOME=/var/cache/guix-build-coordinator-agent"
                 "LC_ALL=en_US.utf8")
@@ -600,7 +602,8 @@
               #:user #$user
               #:environment-variables
               `(,(string-append
-                  "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
+                  "GUIX_LOCPATH="
+                  #$(libc-utf8-locales-for-target) "/lib/locale")
                 "LC_ALL=en_US.utf8")
               #:log-file "/var/log/guix-build-coordinator/queue-builds.log"))))
       (stop #~(make-kill-destructor))
@@ -712,7 +715,8 @@ ca-certificates.crt file in the system profile."
                 #:pid-file "/var/run/guix-data-service/pid"
                 #:environment-variables
                 `(,(string-append
-                    "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
+                    "GUIX_LOCPATH="
+                    #$(libc-utf8-locales-for-target) "/lib/locale")
                   "LC_ALL=en_US.UTF-8")
                 #:log-file "/var/log/guix-data-service/web.log"))
       (stop #~(make-kill-destructor)))
@@ -733,7 +737,8 @@ ca-certificates.crt file in the system profile."
                 `("HOME=/var/lib/guix-data-service"
                   "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt"
                   ,(string-append
-                    "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
+                    "GUIX_LOCPATH="
+                    #$(libc-utf8-locales-for-target) "/lib/locale")
                   "LC_ALL=en_US.UTF-8")
                 #:log-file "/var/log/guix-data-service/process-jobs.log"))
       (stop #~(make-kill-destructor))))))
@@ -989,7 +994,8 @@ ca-certificates.crt file in the system profile."
                 #:pid-file "/var/run/nar-herder/pid"
                 #:environment-variables
                 `(,(string-append
-                    "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
+                    "GUIX_LOCPATH="
+                    #$(libc-utf8-locales-for-target) "/lib/locale")
                   "LC_ALL=en_US.utf8"
                   #$@extra-environment-variables)
                 #:log-file "/var/log/nar-herder/server.log"))
@@ -1108,7 +1114,8 @@ ca-certificates.crt file in the system profile."
                 #:directory "/var/lib/bffe"
                 #:environment-variables
                 `(,(string-append
-                    "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
+                    "GUIX_LOCPATH="
+                    #$(libc-utf8-locales-for-target) "/lib/locale")
                   "LC_ALL=en_US.utf8"
                   #$@extra-environment-variables)
                 #:log-file "/var/log/bffe/server.log"))
diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm
index 1f01b39a21..9ee0d93030 100644
--- a/gnu/services/linux.scm
+++ b/gnu/services/linux.scm
@@ -41,6 +41,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-171)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:export (earlyoom-configuration
@@ -252,13 +253,9 @@ more information)."
   (prefix fstrim-))
 
 (define (serialize-fstrim-configuration config)
-  (concatenate
-   (filter list?
-           (map (lambda (field)
-                  ((configuration-field-serializer field)
-                   (configuration-field-name field)
-                   ((configuration-field-getter field) config)))
-                fstrim-configuration-fields))))
+  (list-transduce (compose (base-transducer config) tconcatenate)
+                  rcons
+                  fstrim-configuration-fields))
 
 (define (fstrim-mcron-job config)
   (match-record config <fstrim-configuration> (package schedule)
diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm
index 088de8c83b..e907d364da 100644
--- a/gnu/services/mcron.scm
+++ b/gnu/services/mcron.scm
@@ -165,7 +165,7 @@ files."
                             (ice-9 popen) ;for the 'schedule' action
                             (ice-9 rdelim)
                             (ice-9 match)
-                            (shepherd support)    ;for '%user-log-dir'
+                            ((shepherd support) #:hide (mkdir-p)) ;for '%user-log-dir'
                             ,@%default-modules))
                  (start #~(make-forkexec-constructor
                            (list #$(file-append mcron "/bin/mcron")
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index f4aff2d979..0508a4282c 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -353,7 +353,12 @@
 
                          (false-if-exception (delete-file #$pid-file))
                          (let ((pid (fork+exec-command
-                                     (cons* dhclient "-nw"
+                                     ;; By default dhclient uses a
+                                     ;; pre-standardization implementation of
+                                     ;; DDNS, which is incompatable with
+                                     ;; non-ISC DHCP servers; thus, pass '-I'.
+                                     ;; <https://kb.isc.org/docs/aa-01091>.
+                                     (cons* dhclient "-nw" "-I"
                                             "-pf" #$pid-file ifaces))))
                            (and (zero? (cdr (waitpid pid)))
                                 (read-pid-file #$pid-file)))))
@@ -1808,7 +1813,10 @@ table inet filter {
     ct state { established, related } accept
 
     # allow from loopback
-    iifname lo accept
+    iif lo accept
+    # drop connections to lo not coming from lo
+    iif != lo ip daddr 127.0.0.1/8 drop
+    iif != lo ip6 daddr ::1/128 drop
 
     # allow icmp
     ip protocol icmp accept
diff --git a/gnu/services/rsync.scm b/gnu/services/rsync.scm
index 42e4d0247e..e85dd50934 100644
--- a/gnu/services/rsync.scm
+++ b/gnu/services/rsync.scm
@@ -291,6 +291,7 @@ please use 'modules' instead~%")))
                                        (make-socket-address AF_INET6 IN6ADDR_ANY
                                                             #$port-number)))
                                      '()))
+                           #:service-name-stem "rsync"
                            #:user #$user
                            #:group #$group)
                           (make-forkexec-constructor #$rsync-command
diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm
index 23ccb8d403..c9b5d6cd99 100644
--- a/gnu/services/telephony.scm
+++ b/gnu/services/telephony.scm
@@ -37,6 +37,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-171)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:export (jami-account
@@ -116,15 +117,10 @@
   (or (string? val)
       (computed-file? val)))
 
-(define (string-list? val)
-  (and (list? val)
-       (and-map string? val)))
+(define account-fingerprint-list?
+  (list-of account-fingerprint?))
 
-(define (account-fingerprint-list? val)
-  (and (list? val)
-       (and-map account-fingerprint? val)))
-
-(define-maybe string-list)
+(define-maybe list-of-strings)
 
 (define-maybe/no-serialization account-fingerprint-list)
 
@@ -134,7 +130,7 @@
 
 ;;; The following serializers are used to derive an account details alist from
 ;;; a <jami-account> record.
-(define (serialize-string-list _ val)
+(define (serialize-list-of-strings _ val)
   (string-join val ";"))
 
 (define (serialize-boolean _ val)
@@ -187,7 +183,7 @@ maintain communication between devices on such network even when the
 connection to the the Internet has been lost.  When left unspecified, the
 value from the account archive prevails.")
   (bootstrap-hostnames
-   maybe-string-list
+   maybe-list-of-strings
    "A list of hostnames or IPs pointing to OpenDHT nodes, that should be used
 to initially join the OpenDHT network.  When left unspecified, the value from
 the account archive prevails.")
@@ -204,26 +200,23 @@ SET-ACCOUNT-DETAILS."
       ('rendezvous-point? "Account.rendezVous")
       ('peer-discovery? "Account.peerDiscovery")
       ('bootstrap-hostnames "Account.hostname")
-      ('name-server-uri "RingNS.uri")
-      (_ #f)))
+      ('name-server-uri "RingNS.uri")))
 
-  (filter-map (lambda (field)
-                (and-let* ((name (field-name->account-detail
+  (define jami-account-transducer
+    (compose (tremove empty-serializer?)
+             (tfilter-maybe-value jami-account-object)
+             (tmap (lambda (field)
+                     (let* ((name (field-name->account-detail
                                   (configuration-field-name field)))
-                           (value ((configuration-field-serializer field)
-                                   name ((configuration-field-getter field)
-                                         jami-account-object)))
-                           ;; The define-maybe default serializer produces an
-                           ;; empty string for unspecified values.
-                           (value* (if (string-null? value)
-                                       #f
-                                       value)))
-                  (cons name value*)))
-              jami-account-fields))
-
-(define (jami-account-list? val)
-  (and (list? val)
-       (and-map jami-account? val)))
+                            (value ((configuration-field-serializer field)
+                                    name ((configuration-field-getter field)
+                                          jami-account-object))))
+                       (cons name value))))))
+
+  (list-transduce jami-account-transducer rcons jami-account-fields))
+
+(define jami-account-list?
+  (list-of jami-account?))
 
 (define-maybe/no-serialization jami-account-list)
 
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index 076eca7ea2..f0f0ab3bf1 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -1085,6 +1085,20 @@ that will be listening to receive secret keys on port 1004, TCP."
                                     accounts)
                     (operating-system-user-services os)))))
 
+(define (operating-system-with-locked-root-account os)
+  "Return OS with a 'root' account whose password is uninitialized, thereby
+preventing password-based authentication as 'root'."
+  (define root
+    ;; %ROOT-ACCOUNT has an empty password; change that to an uninitialized
+    ;; password.
+    (user-account
+     (inherit %root-account)
+     (password #f)))
+
+  (operating-system
+    (inherit os)
+    (users (cons root (operating-system-users os)))))
+
 (define %hurd-vm-operating-system
   (operating-system
     (inherit %hurd-default-operating-system)
@@ -1147,8 +1161,14 @@ that will be listening to receive secret keys on port 1004, TCP."
 is added to the OS specified in CONFIG."
   (define transform
     (compose secret-service-operating-system
+             ;; When offloading is enabled, (1) add the 'offloading' account,
+             ;; and (2) prevent users from logging in as 'root' without a
+             ;; password as this would allow any user on the host to populate
+             ;; the host's store indirectly (for example by logging in as root
+             ;; in the Hurd VM over VNC).
              (if (hurd-vm-configuration-offloading? config)
-                 operating-system-with-offloading-account
+                 (compose operating-system-with-locked-root-account
+                          operating-system-with-offloading-account)
                  identity)))
 
   (let* ((os        (transform (hurd-vm-configuration-os config)))
diff --git a/gnu/services/vnc.scm b/gnu/services/vnc.scm
index f90bd7258f..8b9ad0b179 100644
--- a/gnu/services/vnc.scm
+++ b/gnu/services/vnc.scm
@@ -149,7 +149,7 @@ CONFIG, a <xvnc-configuration> object."
     (xvnc display-number geometry depth port ipv4? ipv6? password-file xdmcp?
           inetd? frame-rate security-types localhost? log-level extra-options)
     #~(list #$(file-append xvnc "/bin/Xvnc")
-            #$(format #f ":~a" display-number)
+            #$@(if inetd? '() (list (format #f ":~a" display-number)))
             "-geometry" #$geometry
             "-depth" #$(number->string depth)
             #$@(if inetd?
diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 818226a4f7..9fd2a3f742 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -1498,7 +1498,8 @@ files.")
                '#$(optional anonip-configuration-regex "--regex"))
               ;; Run in a UTF-8 locale
               #:environment-variables
-              (list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales
+              (list (string-append "GUIX_LOCPATH="
+                                   #$(libc-utf8-locales-for-target)
                                    "/lib/locale")
                     "LC_ALL=en_US.utf8")))
 
@@ -1976,7 +1977,8 @@ WSGIPassAuthorization On
 (define (mumi-shepherd-services config)
   (define environment
     #~(list "LC_ALL=en_US.utf8"
-            (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales
+            (string-append "GUIX_LOCPATH="
+                           #$(libc-utf8-locales-for-target)
                            "/lib/locale")))
 
   (match config
@@ -2101,7 +2103,7 @@ root=/srv/gemini
 
 (define gmnisrv-service-type
   (service-type
-   (name 'guix)
+   (name 'gmnisrv)
    (extensions
     (list (service-extension activation-service-type
                              (const %gmnisrv-activation))