@@ -41778,59 +41778,155 @@ Miscellaneous Services
@cindex OCI-backed, Shepherd services
@subsubheading OCI backed services
-Should you wish to manage your Docker containers with the same consistent
-interface you use for your other Shepherd services,
-@var{oci-container-service-type} is the tool to use: given an
-@acronym{Open Container Initiative, OCI} container image, it will run it in a
+Should you wish to manage your @acronym{Open Container Initiative, OCI} containers
+with the same consistent interface you use for your other Shepherd services,
+@var{oci-service-type} is the tool to use: given an
+OCI container image, it will run it in a
Shepherd service. One example where this is useful: it lets you run services
-that are available as Docker/OCI images but not yet packaged for Guix.
+that are available as OCI images but not yet packaged for Guix.
-@defvar oci-container-service-type
+@defvar oci-service-type
-This is a thin wrapper around Docker's CLI that executes OCI images backed
+This is a thin wrapper around Docker's or Podman's CLI that executes OCI images backed
processes as Shepherd Services.
@lisp
-(service oci-container-service-type
- (list
- (oci-container-configuration
- (network "host")
- (image
- (oci-image
- (repository "guile")
- (tag "3")
- (value (specifications->manifest '("guile")))
- (pack-options '(#:symlinks (("/bin/guile" -> "bin/guile"))
- #:max-layers 2))))
- (entrypoint "/bin/guile")
- (command
- '("-c" "(display \"hello!\n\")")))
- (oci-container-configuration
- (image "prom/prometheus")
- (ports
- '(("9000" . "9000")
- ("9090" . "9090"))))
- (oci-container-configuration
- (image "grafana/grafana:10.0.1")
- (network "host")
- (volumes
- '("/var/lib/grafana:/var/lib/grafana")))))
+(simple-service 'oci-provisioning
+ oci-service-type
+ (oci-extension
+ (networks
+ (list
+ (oci-network-configuration (name "monitoring"))))
+ (containers
+ (list
+ (oci-container-configuration
+ (network "monitoring")
+ (image
+ (oci-image
+ (repository "guile")
+ (tag "3")
+ (value (specifications->manifest '("guile")))
+ (pack-options '(#:symlinks (("/bin/guile" -> "bin/guile"))
+ #:max-layers 2))))
+ (entrypoint "/bin/guile")
+ (command
+ '("-c" "(display \"hello!\n\")")))
+ (oci-container-configuration
+ (image "prom/prometheus")
+ (network "host")
+ (ports
+ '(("9000" . "9000")
+ ("9090" . "9090"))))
+ (oci-container-configuration
+ (image "grafana/grafana:10.0.1")
+ (network "host")
+ (volumes
+ '("/var/lib/grafana:/var/lib/grafana")))))))
@end lisp
In this example three different Shepherd services are going to be added to the
system. Each @code{oci-container-configuration} record translates to a
-@code{docker run} invocation and its fields directly map to options. You can
-refer to the
-@url{https://docs.docker.com/engine/reference/commandline/run,upstream}
-documentation for the semantics of each value. If the images are not found,
-they will be
-@url{https://docs.docker.com/engine/reference/commandline/pull/,pulled}. The
+@command{docker run} or @command{podman run} invocation and its fields directly
+map to options. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html,Podman}
+upstream documentation for semantics of each value. If the images are not found,
+they will be pulled. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/pull/,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-pull.1.html,Podman}
+upstream documentation for semantics. The
services with @code{(network "host")} are going to be attached to the
host network and are supposed to behave like native processes with regard to
networking.
@end defvar
+@c %start of fragment
+
+@deftp {Data Type} oci-configuration
+Available @code{oci-configuration} fields are:
+
+@table @asis
+@item @code{runtime} (default: @code{'docker}) (type: symbol)
+The OCI runtime to use to run commands. It can be either @code{'docker} or
+@code{'podman}.
+
+@item @code{runtime-cli} (type: maybe-package)
+The OCI runtime command line to be installed in the system profile and used
+to provision OCI resources. When unset it will default to @code{docker-cli}
+package for the @code{'docker} runtime or to @code{podman} package for the
+@code{'podman} runtime.
+
+@item @code{user} (default: @code{"oci-container"}) (type: string)
+The user name under whose authority OCI commands will be run.
+
+@item @code{group} (default: @code{"docker"}) (type: string)
+The group name under whose authority OCI commands will be run. When
+using the @code{'podman} OCI runtime, this field will be ignored and the
+default group of the user configured in the @code{user} field will be used.
+
+@item @code{subuids-range} (type: maybe-subid-range)
+An optional @code{subid-range} record allocating subuids for the user from
+the @code{user} field. When unset, with the rootless Podman OCI runtime, it
+defaults to @code{(subid-range (name "oci-container"))}.
+
+@item @code{subgids-range} (type: maybe-subid-range)
+An optional @code{subid-range} record allocating subgids for the user from
+the @code{user} field. When unset, with the rootless Podman OCI runtime, it
+defaults to @code{(subid-range (name "oci-container"))}.
+
+@item @code{containers} (default: @code{'()}) (type: list-of-oci-containers)
+The list of @code{oci-container-configuration} records representing the
+containers to provision. Most users are supposed not to use this field and use
+the @code{oci-extension} record instead.
+
+@item @code{networks} (default: @code{'()}) (type: list-of-oci-networks)
+The list of @code{oci-network-configuration} records representing the
+containers to provision. Most users are supposed not to use this field and use
+the @code{oci-extension} record instead.
+
+@item @code{volumes} (default: @code{'()}) (type: list-of-oci-volumes)
+The list of @code{oci-volumes-configuration} records representing the
+containers to provision. Most users are supposed not to use this field and use
+the @code{oci-extension} record instead.
+
+@item @code{verbose?} (default: @code{#f}) (type: boolean)
+When true, additional output will be printed, allowing to better follow the
+flow of execution.
+
+@end table
+
+@end deftp
+
+
+@c %end of fragment
+
+@c %start of fragment
+
+@deftp {Data Type} oci-extension
+Available @code{oci-extension} fields are:
+
+@table @asis
+@item @code{containers} (default: @code{'()}) (type: list-of-oci-containers)
+The list of @code{oci-container-configuration} records representing the
+containers to provision.
+
+@item @code{networks} (default: @code{'()}) (type: list-of-oci-networks)
+The list of @code{oci-network-configuration} records representing the
+containers to provision.
+
+@item @code{volumes} (default: @code{'()}) (type: list-of-oci-volumes)
+The list of @code{oci-volumes-configuration} records representing the
+containers to provision.
+
+@end table
+
+@end deftp
+
+
+@c %end of fragment
+
+
@c %start of fragment
@deftp {Data Type} oci-container-configuration
@@ -41850,16 +41946,16 @@ Miscellaneous Services
Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
@item @code{host-environment} (default: @code{'()}) (type: list)
-Set environment variables in the host environment where @command{docker
-run} is invoked. This is especially useful to pass secrets from the
-host to the container without having them on the @command{docker run}'s
-command line: by setting the @code{MYSQL_PASSWORD} on the host and by passing
+Set environment variables in the host environment where @command{docker run}
+or @command{podman run} are invoked. This is especially useful to pass secrets
+from the host to the container without having them on the OCI runtime command line,
+for example: by setting the @code{MYSQL_PASSWORD} on the host and by passing
@code{--env MYSQL_PASSWORD} through the @code{extra-arguments} field, it is
possible to securely set values in the container environment. This field's
value can be a list of pairs or strings, even mixed:
@lisp
-(list '("LANGUAGE\" . "eo:ca:eu")
+(list '("LANGUAGE" . "eo:ca:eu")
"JAVA_HOME=/opt/java")
@end lisp
@@ -41867,22 +41963,24 @@ Miscellaneous Services
directly to @code{make-forkexec-constructor}.
@item @code{environment} (default: @code{'()}) (type: list)
-Set environment variables. This can be a list of pairs or strings, even mixed:
+Set environment variables inside the container. This can be a list of pairs
+or strings, even mixed:
@lisp
(list '("LANGUAGE" . "eo:ca:eu")
"JAVA_HOME=/opt/java")
@end lisp
-Pair members can be strings, gexps or file-like objects.
-Strings are passed directly to the Docker CLI. You can refer to the
-@uref{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
-documentation for semantics.
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the OCI runtime CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#env,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#env-e-env,Podman}
+upstream documentation for semantics.
@item @code{image} (type: string-or-oci-image)
The image used to build the container. It can be a string or an
-@code{oci-image} record. Strings are resolved by the Docker Engine, and
-follow the usual format
+@code{oci-image} record. Strings are resolved by the OCI runtime,
+and follow the usual format
@code{myregistry.local:5000/testing/test-image:tag}.
@item @code{provision} (default: @code{""}) (type: string)
@@ -41910,7 +42008,7 @@ Miscellaneous Services
by the service.
@item @code{network} (default: @code{""}) (type: string)
-Set a Docker network for the spawned container.
+Set an OCI network for the spawned container.
@item @code{ports} (default: @code{'()}) (type: list)
Set the port or port ranges to expose from the spawned container. This can be a
@@ -41921,10 +42019,11 @@ Miscellaneous Services
"10443:443")
@end lisp
-Pair members can be strings, gexps or file-like objects.
-Strings are passed directly to the Docker CLI. You can refer to the
-@uref{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
-documentation for semantics.
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the OCI runtime CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#publish,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#publish-p-ip-hostport-containerport-protocol,Podman}
+upstream documentation for semantics.
@item @code{volumes} (default: @code{'()}) (type: list)
Set volume mappings for the spawned container. This can be a
@@ -41935,25 +42034,95 @@ Miscellaneous Services
"/gnu/store:/gnu/store")
@end lisp
-Pair members can be strings, gexps or file-like objects.
-Strings are passed directly to the Docker CLI. You can refer to the
-@uref{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
-documentation for semantics.
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the OCI runtime CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#volume,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#volume-v-source-volume-host-dir-container-dir-options,Podman}
+upstream documentation for semantics.
@item @code{container-user} (default: @code{""}) (type: 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.
+@url{https://docs.docker.com/engine/reference/run/#user,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#user-u-user-group,Podman}
+upstream documentation for semantics.
@item @code{workdir} (default: @code{""}) (type: string)
Set the current working directory for the spawned Shepherd service.
You can refer to the
-@url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
-documentation for semantics.
+@url{https://docs.docker.com/engine/reference/run/#workdir,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#workdir-w-dir,Podman}
+upstream documentation for semantics.
+
+@item @code{extra-arguments} (default: @code{'()}) (type: list)
+A list of strings, gexps or file-like objects that will be directly passed
+to the @command{docker run} or @command{podman run} invokation.
+
+@end table
+
+@end deftp
+
+
+@c %end of fragment
+
+@c %start of fragment
+
+@deftp {Data Type} oci-network-configuration
+Available @code{oci-network-configuration} fields are:
+
+@table @asis
+@item @code{name} (type: string)
+The name of the OCI network to provision.
+
+@item @code{driver} (type: maybe-string)
+The driver to manage the network.
+
+@item @code{gateway} (type: maybe-string)
+IPv4 or IPv6 gateway for the subnet.
+
+@item @code{internal?} (default: @code{#f}) (type: boolean)
+Restrict external access to the network
+
+@item @code{ip-range} (type: maybe-string)
+Allocate container ip from a sub-range in CIDR format.
+
+@item @code{ipam-driver} (type: maybe-string)
+IP Address Management Driver.
+
+@item @code{ipv6?} (default: @code{#f}) (type: boolean)
+Enable IPv6 networking.
+
+@item @code{subnet} (type: maybe-string)
+Subnet in CIDR format that represents a network segment.
+
+@item @code{labels} (default: @code{'()}) (type: list)
+The list of labels that will be used to tag the current volume.
+
+@item @code{extra-arguments} (default: @code{'()}) (type: list)
+A list of strings, gexps or file-like objects that will be directly
+passed to the runtime invokation.
+
+@end table
+
+@end deftp
+
+
+@c %end of fragment
+
+@c %start of fragment
+
+@deftp {Data Type} oci-volume-configuration
+Available @code{oci-volume-configuration} fields are:
+
+@table @asis
+@item @code{name} (type: string)
+The name of the OCI volume to provision.
+
+@item @code{labels} (default: @code{'()}) (type: list)
+The list of labels that will be used to tag the current volume.
@item @code{extra-arguments} (default: @code{'()}) (type: list)
A list of strings, gexps or file-like objects that will be directly
-passed to the @command{docker run} invocation.
+passed to the runtime invokation.
@end table
@@ -41,6 +41,7 @@ (define-module (gnu services containers)
#:use-module ((guix scripts pack) #:prefix pack:)
#:use-module (guix store)
#:use-module (srfi srfi-1)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (rootless-podman-configuration
rootless-podman-configuration?
@@ -96,8 +97,68 @@ (define-module (gnu services containers)
oci-container-configuration-workdir
oci-container-configuration-extra-arguments
+ list-of-oci-containers?
+ list-of-oci-networks?
+ list-of-oci-volumes?
+
+ %oci-supported-runtimes
+ oci-sanitize-runtime
+ oci-runtime-system-requirement
+ oci-runtime-cli
+ oci-runtime-system-cli
+ oci-runtime-name
+ oci-runtime-group
+
+ oci-network-configuration
+ oci-network-configuration?
+ oci-network-configuration-fields
+ oci-network-configuration-name
+ oci-network-configuration-driver
+ oci-network-configuration-gateway
+ oci-network-configuration-internal?
+ oci-network-configuration-ip-range
+ oci-network-configuration-ipam-driver
+ oci-network-configuration-ipv6?
+ oci-network-configuration-subnet
+ oci-network-configuration-labels
+ oci-network-configuration-extra-arguments
+
+ oci-volume-configuration
+ oci-volume-configuration?
+ oci-volume-configuration-fields
+ oci-volume-configuration-name
+ oci-volume-configuration-labels
+ oci-volume-configuration-extra-arguments
+
+ oci-configuration
+ oci-configuration?
+ oci-configuration-fields
+ oci-configuration-runtime
+ oci-configuration-runtime-cli
+ oci-configuration-user
+ oci-configuration-group
+ oci-configuration-containers
+ oci-configuration-networks
+ oci-configuration-volumes
+ oci-configuration-verbose?
+
+ oci-extension
+ oci-extension?
+ oci-extension-fields
+ oci-extension-containers
+ oci-extension-networks
+ oci-extension-volumes
+
+ oci-networks-shepherd-name
+ oci-volumes-shepherd-name
+
oci-container-shepherd-service
- %oci-container-accounts))
+ oci-service-type
+ oci-service-accounts
+ oci-service-profile
+ oci-service-subids
+ oci-state->shepherd-services
+ oci-configuration->shepherd-services))
(define (gexp-or-string? value)
(or (gexp? value)
@@ -294,9 +355,42 @@ (define rootless-podman-service-type
;;;
-;;; OCI container.
+;;; OCI provisioning service.
;;;
+(define %oci-supported-runtimes
+ '(docker podman))
+
+(define (oci-runtime-system-requirement runtime)
+ "Return a list of Shepherd service names required by a given OCI runtime,
+before it is able to run containers."
+ (if (eq? 'podman runtime)
+ '(cgroups2-fs-owner cgroups2-limits
+ rootless-podman-shared-root-fs)
+ '(dockerd)))
+
+(define (oci-runtime-name runtime)
+ "Return a human readable name for a given OCI runtime."
+ (if (eq? 'podman runtime)
+ "Podman" "Docker"))
+
+(define (oci-runtime-group runtime maybe-group)
+ "Implement the logic behind selection of the group that is to be used by
+Shepherd to execute OCI commands."
+ (if (maybe-value-set? maybe-group)
+ maybe-group
+ (if (eq? 'podman runtime)
+ "cgroup"
+ "docker")))
+
+(define (oci-sanitize-runtime value)
+ (unless (member value %oci-supported-runtimes)
+ (raise
+ (formatted-message
+ (G_ "OCI runtime must be a symbol and one of ~a,
+but ~a was found") %oci-supported-runtimes value)))
+ value)
+
(define (oci-sanitize-pair pair delimiter)
(define (valid? member)
(or (string? member)
@@ -345,6 +439,11 @@ (define (oci-sanitize-volumes value)
;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
(oci-sanitize-mixed-list "volumes" value ":"))
+(define (oci-sanitize-labels value)
+ ;; Expected spec format:
+ ;; '(("foo" . "bar") "foo=bar")
+ (oci-sanitize-mixed-list "labels" value "="))
+
(define (oci-sanitize-shepherd-actions value)
(map
(lambda (el)
@@ -372,6 +471,7 @@ (define (oci-sanitize-extra-arguments value)
value))
(define (oci-image-reference image)
+ "Return a string OCI image reference representing IMAGE."
(if (string? image)
image
(string-append (oci-image-repository image)
@@ -390,7 +490,19 @@ (define (string-or-oci-image? image)
(define list-of-symbols?
(list-of symbol?))
+(define (list-of-oci-records? name predicate value)
+ (map
+ (lambda (el)
+ (if (predicate el)
+ el
+ (raise
+ (formatted-message
+ (G_ "~a contains an illegal value: ~a") name el))))
+ value))
+
(define-maybe/no-serialization string)
+(define-maybe/no-serialization package)
+(define-maybe/no-serialization subid-range)
(define-configuration/no-serialization oci-image
(repository
@@ -436,10 +548,12 @@ (define-configuration/no-serialization oci-image
(define-configuration/no-serialization oci-container-configuration
(user
(string "oci-container")
- "The user under whose authority docker commands will be run.")
+ "The user name under whose authority OCI commands will be run.")
(group
(string "docker")
- "The group under whose authority docker commands will be run.")
+ "The group name under whose authority OCI commands will be run. When
+using the @code{'podman} OCI runtime, this field will be ignored and the
+default group of the user configured in the @code{user} field will be used.")
(command
(list-of-strings '())
"Overwrite the default command (@code{CMD}) of the image.")
@@ -449,9 +563,9 @@ (define-configuration/no-serialization oci-container-configuration
(host-environment
(list '())
"Set environment variables in the host environment where @command{docker run}
-is invoked. This is especially useful to pass secrets from the host to the
-container without having them on the @command{docker run}'s command line: by
-setting the @code{MYSQL_PASSWORD} on the host and by passing
+or @command{podman run} are invoked. This is especially useful to pass secrets
+from the host to the container without having them on the OCI runtime command line,
+for example: by setting the @code{MYSQL_PASSWORD} on the host and by passing
@code{--env MYSQL_PASSWORD} through the @code{extra-arguments} field, it is
possible to securely set values in the container environment. This field's
value can be a list of pairs or strings, even mixed:
@@ -475,15 +589,16 @@ (define-configuration/no-serialization oci-container-configuration
@end lisp
Pair members can be strings, gexps or file-like objects. Strings 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."
+directly to the OCI runtime CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#env,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#env-e-env,Podman}
+upstream documentation for semantics."
(sanitizer oci-sanitize-environment))
(image
(string-or-oci-image)
"The image used to build the container. It can be a string or an
-@code{oci-image} record. Strings are resolved by the Docker
-Engine, and follow the usual format
+@code{oci-image} record. Strings are resolved by the OCI runtime,
+and follow the usual format
@code{myregistry.local:5000/testing/test-image:tag}.")
(provision
(maybe-string)
@@ -512,7 +627,7 @@ (define-configuration/no-serialization oci-container-configuration
(sanitizer oci-sanitize-shepherd-actions))
(network
(maybe-string)
- "Set a Docker network for the spawned container.")
+ "Set an OCI network for the spawned container.")
(ports
(list '())
"Set the port or port ranges to expose from the spawned container. This can
@@ -524,9 +639,10 @@ (define-configuration/no-serialization oci-container-configuration
@end lisp
Pair members can be strings, gexps or file-like objects. Strings 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."
+directly to the OCI runtime CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#publish,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#publish-p-ip-hostport-containerport-protocol,Podman}
+upstream documentation for semantics."
(sanitizer oci-sanitize-ports))
(volumes
(list '())
@@ -539,63 +655,307 @@ (define-configuration/no-serialization oci-container-configuration
@end lisp
Pair members can be strings, gexps or file-like objects. Strings 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."
+directly to the OCI runtime CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#volume,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#volume-v-source-volume-host-dir-container-dir-options,Podman}
+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.")
+@url{https://docs.docker.com/engine/reference/run/#user,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#user-u-user-group,Podman}
+upstream documentation for semantics.")
(workdir
(maybe-string)
- "Set the current working for the spawned Shepherd service.
+ "Set the current working directory for the spawned Shepherd service.
You can refer to the
-@url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
-documentation for semantics.")
+@url{https://docs.docker.com/engine/reference/run/#workdir,Docker}
+or @url{https://docs.podman.io/en/stable/markdown/podman-run.1.html#workdir-w-dir,Podman}
+upstream documentation for semantics.")
(extra-arguments
(list '())
"A list of strings, gexps or file-like objects that will be directly passed
-to the @command{docker run} invokation."
+to the @command{docker run} or @command{podman run} invokation."
(sanitizer oci-sanitize-extra-arguments)))
-(define oci-container-configuration->options
- (lambda (config)
- (let ((entrypoint
- (oci-container-configuration-entrypoint config))
- (network
- (oci-container-configuration-network config))
- (user
- (oci-container-configuration-container-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 (list-of-oci-containers? value)
+ (list-of-oci-records? "containers" oci-container-configuration? value))
+
+(define-configuration/no-serialization oci-volume-configuration
+ (name
+ (string)
+ "The name of the OCI volume to provision.")
+ (labels
+ (list '())
+ "The list of labels that will be used to tag the current volume."
+ (sanitizer oci-sanitize-labels))
+ (extra-arguments
+ (list '())
+ "A list of strings, gexps or file-like objects that will be directly passed
+to the runtime invokation."
+ (sanitizer oci-sanitize-extra-arguments)))
+
+(define (list-of-oci-volumes? value)
+ (list-of-oci-records? "volumes" oci-volume-configuration? value))
+
+(define-configuration/no-serialization oci-network-configuration
+ (name
+ (string)
+ "The name of the OCI network to provision.")
+ (driver
+ (maybe-string)
+ "The driver to manage the network.")
+ (gateway
+ (maybe-string)
+ "IPv4 or IPv6 gateway for the subnet.")
+ (internal?
+ (boolean #f)
+ "Restrict external access to the network")
+ (ip-range
+ (maybe-string)
+ "Allocate container ip from a sub-range in CIDR format.")
+ (ipam-driver
+ (maybe-string)
+ "IP Address Management Driver.")
+ (ipv6?
+ (boolean #f)
+ "Enable IPv6 networking.")
+ (subnet
+ (maybe-string)
+ "Subnet in CIDR format that represents a network segment.")
+ (labels
+ (list '())
+ "The list of labels that will be used to tag the current volume."
+ (sanitizer oci-sanitize-labels))
+ (extra-arguments
+ (list '())
+ "A list of strings, gexps or file-like objects that will be directly passed
+to the runtime invokation."
+ (sanitizer oci-sanitize-extra-arguments)))
+
+(define (list-of-oci-networks? value)
+ (list-of-oci-records? "networks" oci-network-configuration? value))
+
+(define-configuration/no-serialization oci-configuration
+ (runtime
+ (symbol 'docker)
+ "The OCI runtime to use to run commands. It can be either @code{'docker} or
+@code{'podman}."
+ (sanitizer oci-sanitize-runtime))
+ (runtime-cli
+ (maybe-package)
+ "The OCI runtime command line to be installed in the system profile and used
+to provision OCI resources. When unset it will default to @code{docker-cli}
+package for the @code{'docker} runtime or to @code{podman} package for the
+@code{'podman} runtime.")
+ (user
+ (string "oci-container")
+ "The user name under whose authority OCI runtime commands will be run.")
+ (group
+ (maybe-string)
+ "The group name under whose authority OCI commands will be run. When
+using the @code{'podman} OCI runtime, this field will be ignored and the
+default group of the user configured in the @code{user} field will be used.")
+ (subuids-range
+ (maybe-subid-range)
+ "An optional @code{subid-range} record allocating subuids for the user from
+the @code{user} field. When unset, with the rootless Podman OCI runtime, it
+defaults to @code{(subid-range (name \"oci-container\"))}.")
+ (subgids-range
+ (maybe-subid-range)
+ "An optional @code{subid-range} record allocating subgids for the user from
+the @code{user} field. When unset, with the rootless Podman OCI runtime, it
+defaults to @code{(subid-range (name \"oci-container\"))}.")
+ (containers
+ (list-of-oci-containers '())
+ "The list of @code{oci-container-configuration} records representing the
+containers to provision. Most users are supposed not to use this field and use
+the @code{oci-extension} record instead.")
+ (networks
+ (list-of-oci-networks '())
+ "The list of @code{oci-network-configuration} records representing the
+networks to provision. Most users are supposed not to use this field and use
+the @code{oci-extension} record instead.")
+ (volumes
+ (list-of-oci-volumes '())
+ "The list of @code{oci-volume-configuration} records representing the
+volumes to provision. Most users are supposed not to use this field and use
+the @code{oci-extension} record instead.")
+ (verbose?
+ (boolean #f)
+ "When true, additional output will be printed, allowing to better follow the
+flow of execution."))
+
+(define (oci-runtime-cli runtime runtime-cli path)
+ "Return a gexp that, when lowered, evaluates to the file system path of the OCI
+runtime command requested by the user."
+ (if (string? runtime-cli)
+ ;; It is a user defined absolute path
+ runtime-cli
+ #~(string-append
+ (if #$(maybe-value-set? runtime-cli)
+ #$runtime-cli
+ #$path)
+ (if #$(eq? 'podman runtime)
+ "/bin/podman"
+ "/bin/docker"))))
+
+(define* (oci-runtime-system-cli config #:key (path "/run/current-system/profile"))
+ (let ((runtime-cli
+ (oci-configuration-runtime-cli config))
+ (runtime
+ (oci-configuration-runtime config)))
+ (oci-runtime-cli runtime runtime-cli path)))
+
+(define-configuration/no-serialization oci-extension
+ (containers
+ (list-of-oci-containers '())
+ "The list of @code{oci-container-configuration} records representing the
+containers to add.")
+ (networks
+ (list-of-oci-networks '())
+ "The list of @code{oci-network-configuration} records representing the
+networks to add.")
+ (volumes
+ (list-of-oci-volumes '())
+ "The list of @code{oci-volume-configuration} records representing the
+volumes to add."))
+
+(define (oci-image->container-name image)
+ "Infer the name of an OCI backed Shepherd service from its OCI image."
+ (basename
+ (if (string? image)
+ (first (string-split image #\:))
+ (oci-image-repository image))))
+
+(define (oci-object-command-shepherd-action object-name invokation)
+ "Return a Shepherd action printing a given INVOKATION of an OCI command for the
+given OBJECT-NAME."
+ (shepherd-action
+ (name 'command-line)
+ (documentation
+ (format #f "Prints ~a's OCI runtime command line invokation."
+ object-name))
+ (procedure
+ #~(lambda _
+ (format #t "~a~%" #$invokation)))))
+
+(define (oci-container-shepherd-name runtime config)
+ "Return the name of an OCI backed Shepherd service based on CONFIG.
+The name configured in the configuration record is returned when
+CONFIG's name field has a value, otherwise a name is inferred from CONFIG's
+image field."
+ (define name (oci-container-configuration-provision config))
+ (define image (oci-container-configuration-image config))
+
+ (if (maybe-value-set? name)
+ name
+ (string-append (symbol->string runtime) "-"
+ (oci-image->container-name image))))
+
+(define (oci-networks-shepherd-name runtime)
+ "Return the name of the OCI networks provisioning Shepherd service based on
+RUNTIME."
+ (string-append (symbol->string runtime) "-networks"))
+
+(define (oci-volumes-shepherd-name runtime)
+ "Return the name of the OCI volumes provisioning Shepherd service based on
+RUNTIME."
+ (string-append (symbol->string runtime) "-volumes"))
+
+(define (oci-container-configuration->options config)
+ "Map CONFIG, an oci-container-configuration record, to a gexp that, upon
+lowering, will be evaluated to a list of strings containing command line options
+for the OCI runtime run command."
+ (let ((entrypoint
+ (oci-container-configuration-entrypoint config))
+ (network
+ (oci-container-configuration-network config))
+ (user
+ (oci-container-configuration-container-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-network-configuration->options config)
+ "Map CONFIG, an oci-network-configuration record, to a gexp that, upon
+lowering, will be evaluated to a list of strings containing command line options
+for the OCI runtime network create command."
+ (let ((driver (oci-network-configuration-driver config))
+ (gateway
+ (oci-network-configuration-gateway config))
+ (internal?
+ (oci-network-configuration-internal? config))
+ (ip-range
+ (oci-network-configuration-ip-range config))
+ (ipam-driver
+ (oci-network-configuration-ipam-driver config))
+ (ipv6?
+ (oci-network-configuration-ipv6? config))
+ (subnet
+ (oci-network-configuration-subnet config)))
+ (apply append
+ (filter (compose not unspecified?)
+ `(,(if (maybe-value-set? driver)
+ `("--driver" ,driver)
+ '())
+ ,(if (maybe-value-set? gateway)
+ `("--gateway" ,gateway)
+ '())
+ ,(if internal?
+ `("--internal")
+ '())
+ ,(if (maybe-value-set? ip-range)
+ `("--ip-range" ,ip-range)
+ '())
+ ,(if (maybe-value-set? ipam-driver)
+ `("--ipam-driver" ,ipam-driver)
+ '())
+ ,(if ipv6?
+ `("--ipv6")
+ '())
+ ,(if (maybe-value-set? subnet)
+ `("--subnet" ,subnet)
+ '())
+ ,(append-map
+ (lambda (spec)
+ (list "--label" spec))
+ (oci-network-configuration-labels config)))))))
+
+(define (oci-volume-configuration->options config)
+ "Map CONFIG, an oci-volume-configuration record, to a gexp that, upon
+lowering, will be evaluated to a list of strings containing command line options
+for the OCI runtime volume create command."
+ (append-map
+ (lambda (spec)
+ (list "--label" spec))
+ (oci-volume-configuration-labels config)))
(define* (get-keyword-value args keyword #:key (default #f))
(let ((kv (memq keyword args)))
@@ -604,6 +964,7 @@ (define* (get-keyword-value args keyword #:key (default #f))
default)))
(define (lower-operating-system os target system)
+ "Lower OS, an operating-system record, into a tarball containing an OCI image."
(mlet* %store-monad
((tarball
(lower-object
@@ -613,6 +974,7 @@ (define (lower-operating-system os target system)
(return tarball)))
(define (lower-manifest name image target system)
+ "Lower IMAGE, a manifest record, into a tarball containing an OCI image."
(define value (oci-image-value image))
(define options (oci-image-pack-options image))
(define image-reference
@@ -645,6 +1007,7 @@ (define (lower-manifest name image target system)
(return tarball)))
(define (lower-oci-image name image)
+ "Lower IMAGE, a oci-image record, into a tarball containing an OCI image."
(define value (oci-image-value image))
(define image-target (oci-image-target image))
(define image-system (oci-image-system image))
@@ -675,9 +1038,10 @@ (define (lower-oci-image name image)
#:target target
#:system system)))
-(define (%oci-image-loader name image tag)
- (let ((docker (file-append docker-cli "/bin/docker"))
- (tarball (lower-oci-image name image)))
+(define* (oci-image-loader runtime-cli name image tag #:key (verbose? #f))
+ "Return a file-like object that, once lowered, will evaluate to a program able
+to load IMAGE through RUNTIME-CLI and to tag it with TAG afterwards."
+ (let ((tarball (lower-oci-image name image)))
(with-imported-modules '((guix build utils))
(program-file (format #f "~a-image-loader" name)
#~(begin
@@ -686,102 +1050,536 @@ (define (%oci-image-loader name image tag)
(ice-9 rdelim))
(format #t "Loading image for ~a from ~a...~%" #$name #$tarball)
+ (define load-command
+ (string-append #$runtime-cli
+ " load -i " #$tarball))
+ (when #$verbose?
+ (format #t "Running ~a~%" load-command))
(define line
(read-line
- (open-input-pipe
- (string-append #$docker " load -i " #$tarball))))
+ (open-input-pipe load-command)))
(unless (or (eof-object? line)
(string-null? line))
(format #t "~a~%" line)
- (let ((repository&tag
- (string-drop line
- (string-length
- "Loaded image: "))))
+ (let* ((repository&tag
+ (string-drop line
+ (string-length
+ "Loaded image: ")))
+ (tag-command
+ (list #$runtime-cli "tag" repository&tag #$tag)))
+
+ (when #$verbose?
+ (format #t "Running~{ ~a~}~%" tag-command))
- (invoke #$docker "tag" repository&tag #$tag)
+ (apply invoke tag-command)
(format #t "Tagged ~a with ~a...~%" #$tarball #$tag))))))))
-(define (oci-container-shepherd-service config)
- (define (guess-name name image)
- (if (maybe-value-set? name)
- name
- (string-append "docker-"
- (basename
- (if (string? image)
- (first (string-split image #\:))
- (oci-image-repository image))))))
-
- (let* ((docker (file-append docker-cli "/bin/docker"))
- (actions (oci-container-configuration-shepherd-actions config))
+(define* (oci-container-entrypoint runtime-cli name image image-reference
+ invokation #:key (verbose? #f))
+ "Return a file-like object that, once lowered, will evaluate to the entrypoint
+for the Shepherd service that will run IMAGE through RUNTIME-CLI."
+ (program-file
+ (string-append "oci-entrypoint-" name)
+ #~(begin
+ (use-modules (ice-9 format))
+ (when #$verbose?
+ (format #t "Running in verbose mode..."))
+ (define invokation (list #$@invokation))
+ #$@(if (oci-image? image)
+ #~((system*
+ #$(oci-image-loader
+ runtime-cli name image
+ image-reference #:verbose? verbose?)))
+ #~())
+ (when #$verbose?
+ (format #t "Running~{ ~a~}~%" invokation))
+ (apply execlp invokation))))
+
+(define* (oci-container-shepherd-service runtime runtime-cli config
+ #:key
+ (oci-requirement '())
+ (user #f)
+ (group #f)
+ (verbose? #f))
+ "Return a Shepherd service object that will run the OCI container represented
+by CONFIG through RUNTIME-CLI."
+ (let* ((actions (oci-container-configuration-shepherd-actions config))
(auto-start?
(oci-container-configuration-auto-start? config))
- (user (oci-container-configuration-user config))
- (group (oci-container-configuration-group config))
+ (user (or user (oci-container-configuration-user config)))
+ (group (if (and group (maybe-value-set? group))
+ group
+ (oci-container-configuration-group config)))
(host-environment
(oci-container-configuration-host-environment config))
(command (oci-container-configuration-command config))
(log-file (oci-container-configuration-log-file config))
- (provision (oci-container-configuration-provision config))
(requirement (oci-container-configuration-requirement config))
(respawn?
(oci-container-configuration-respawn? config))
(image (oci-container-configuration-image config))
(image-reference (oci-image-reference image))
(options (oci-container-configuration->options config))
- (name (guess-name provision image))
+ (name
+ (oci-container-shepherd-name runtime config))
(extra-arguments
- (oci-container-configuration-extra-arguments config)))
+ (oci-container-configuration-extra-arguments config))
+ (invokation
+ ;; run [OPTIONS] IMAGE [COMMAND] [ARG...]
+ `(,runtime-cli ,runtime-cli "run"
+ "--rm" "--name" ,name
+ ,@options ,@extra-arguments
+ ,image-reference ,@command)))
(shepherd-service (provision `(,(string->symbol name)))
- (requirement `(dockerd user-processes ,@requirement))
+ (requirement `(,@(oci-runtime-system-requirement runtime)
+ user-processes
+ ,@oci-requirement
+ ,@requirement))
(respawn? respawn?)
(auto-start? auto-start?)
(documentation
(string-append
- "Docker backed Shepherd service for "
+ (oci-runtime-name runtime) " backed Shepherd service for "
(if (oci-image? image) name image) "."))
(start
- #~(lambda ()
- #$@(if (oci-image? image)
- #~((invoke #$(%oci-image-loader
- name image image-reference)))
- #~())
+ #~(lambda _
(fork+exec-command
- ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
- (list #$docker "run" "--rm" "--name" #$name
- #$@options #$@extra-arguments
- #$image-reference #$@command)
+ (list
+ #$(oci-container-entrypoint
+ runtime-cli name image image-reference
+ invokation #:verbose? verbose?))
#:user #$user
- #:group #$group
+ #:group
+ (if #$(eq? runtime 'podman)
+ (group:name
+ (getgrgid
+ (passwd:gid (getpwnam #$user))))
+ #$group)
#$@(if (maybe-value-set? log-file)
(list #:log-file log-file)
'())
#:environment-variables
- (list #$@host-environment))))
+ (append
+ (list #$@host-environment)
+ (if #$(eq? runtime 'podman)
+ (list
+ (string-append
+ "HOME=" (passwd:dir (getpwnam #$user))))
+ '())))))
(stop
#~(lambda _
- (invoke #$docker "rm" "-f" #$name)))
+ (invoke #$runtime-cli "rm" "-f" #$name)))
(actions
- (if (oci-image? image)
- '()
- (append
+ (append
+ (list
+ (oci-object-command-shepherd-action
+ name #~(string-join (cdr (list #$@invokation)) " ")))
+ (if (oci-image? image)
+ '()
(list
- (shepherd-action
- (name 'pull)
- (documentation
- (format #f "Pull ~a's image (~a)."
- name image))
- (procedure
- #~(lambda _
- (invoke #$docker "pull" #$image)))))
- actions))))))
-
-(define %oci-container-accounts
+ (let ((service-name name))
+ (shepherd-action
+ (name 'pull)
+ (documentation
+ (format #f "Pull ~a's image (~a)."
+ service-name image))
+ (procedure
+ #~(lambda _
+ (invoke #$runtime-cli "pull" #$image)))))))
+ actions)))))
+
+(define (oci-object-create-invokation object runtime-cli name options
+ extra-arguments)
+ "Return a gexp that, upon lowering, will evaluate to the OCI runtime
+invokation for creating networks and volumes."
+ ;; network|volume create [options] [NAME]
+ #~(list #$runtime-cli #$object "create"
+ #$@options #$@extra-arguments #$name))
+
+(define (format-oci-invokations invokations)
+ "Return a gexp that, upon lowering, will evaluate to a formatted message
+containing the INVOKATIONS that the OCI runtime will execute to provision
+networks or volumes."
+ #~(string-join (map (lambda (i) (string-join i " "))
+ (list #$@invokations))
+ "\n"))
+
+(define* (oci-object-create-script object runtime runtime-cli invokations
+ #:key (verbose? #f))
+ "Return a file-like object that, once lowered, will evaluate to a program able
+to create OCI networks and volumes through RUNTIME-CLI."
+ (define runtime-string (symbol->string runtime))
+ (program-file
+ (string-append runtime-string "-" object "s-create.scm")
+ #~(begin
+ (use-modules (ice-9 format)
+ (ice-9 match)
+ (ice-9 popen)
+ (ice-9 rdelim)
+ (srfi srfi-1))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define (object-exists? name)
+ (if (string=? #$runtime-string "podman")
+ (let ((command
+ (list #$runtime-cli
+ #$object "exists" name)))
+ (when #$verbose?
+ (format #t "Running~{ ~a~}~%" command))
+ (define exit-code (status:exit-val (apply system* command)))
+ (when #$verbose?
+ (format #t "Exit code: ~a~%" exit-code))
+ (equal? EXIT_SUCCESS exit-code))
+ (let ((command
+ (string-append #$runtime-cli
+ " " #$object " ls --format "
+ "\"{{.Name}}\"")))
+ (when #$verbose?
+ (format #t "Running ~a~%" command))
+ (member name (read-lines (open-input-pipe command))))))
+
+ (for-each
+ (lambda (invokation)
+ (define name (last invokation))
+ (if (object-exists? name)
+ (format #t "~a ~a ~a already exists, skipping creation.~%"
+ #$(oci-runtime-name runtime) name #$object)
+ (begin
+ (when #$verbose?
+ (format #t "Running~{ ~a~}~%" invokation))
+ (let ((exit-code (status:exit-val (apply system* invokation))))
+ (when #$verbose?
+ (format #t "Exit code: ~a~%" exit-code))))))
+ (list #$@invokations)))))
+
+(define* (oci-object-shepherd-service object runtime runtime-cli name requirement invokations
+ #:key
+ (user #f)
+ (group #f)
+ (verbose? #f))
+ "Return a Shepherd service object that will create the OBJECTs represented
+by INVOKATIONS through RUNTIME-CLI."
+ (shepherd-service (provision `(,(string->symbol name)))
+ (requirement `(user-processes ,@requirement))
+ (one-shot? #t)
+ (documentation
+ (string-append
+ (oci-runtime-name runtime) " " object
+ " provisioning service"))
+ (start
+ #~(lambda _
+ (fork+exec-command
+ (list
+ #$(oci-object-create-script
+ object runtime runtime-cli
+ invokations
+ #:verbose? verbose?))
+ #:user #$user
+ #:group
+ (if #$(eq? runtime 'podman)
+ (group:name
+ (getgrgid
+ (passwd:gid (getpwnam #$user))))
+ #$group)
+ #$@(if (eq? runtime 'podman)
+ (list
+ #:environment-variables
+ #~(list
+ (string-append
+ "HOME=" (passwd:dir (getpwnam #$user)))))
+ '()))))
+ (actions
+ (list
+ (oci-object-command-shepherd-action
+ name (format-oci-invokations invokations))))))
+
+(define* (oci-networks-shepherd-service runtime runtime-cli name networks
+ #:key
+ (user #f)
+ (group #f)
+ (runtime-requirement '())
+ (default-requirement '(networking))
+ (verbose? #f))
+ "Return a Shepherd service object that will create the networks represented
+in CONFIG."
+ (let ((invokations
+ (map
+ (lambda (network)
+ (oci-object-create-invokation
+ "network" runtime-cli
+ (oci-network-configuration-name network)
+ (oci-network-configuration->options network)
+ (oci-network-configuration-extra-arguments network)))
+ networks)))
+
+ (oci-object-shepherd-service
+ "network" runtime runtime-cli name
+ (append default-requirement runtime-requirement) invokations
+ #:user user #:group group #:verbose? verbose?)))
+
+(define* (oci-volumes-shepherd-service runtime runtime-cli name volumes
+ #:key (user #f) (group #f) (verbose? #f)
+ (runtime-requirement '()))
+ "Return a Shepherd service object that will create the volumes represented
+in CONFIG."
+ (let ((invokations
+ (map
+ (lambda (volume)
+ (oci-object-create-invokation
+ "volume" runtime-cli
+ (oci-volume-configuration-name volume)
+ (oci-volume-configuration->options volume)
+ (oci-volume-configuration-extra-arguments volume)))
+ volumes)))
+
+ (oci-object-shepherd-service
+ "volume" runtime runtime-cli name runtime-requirement invokations
+ #:user user #:group group #:verbose? verbose?)))
+
+(define (oci-service-accounts config)
+ (define user (oci-configuration-user config))
+ (define maybe-group (oci-configuration-group config))
+ (define runtime (oci-configuration-runtime config))
(list (user-account
- (name "oci-container")
+ (name user)
(comment "OCI services account")
- (group "docker")
- (system? #t)
- (home-directory "/var/empty")
+ (group "users")
+ (supplementary-groups
+ (list (oci-runtime-group runtime maybe-group)))
+ (system? (eq? 'docker runtime))
+ (home-directory (if (eq? 'podman runtime)
+ (string-append "/home/" user)
+ "/var/empty"))
+ (create-home-directory? (eq? 'podman runtime))
(shell (file-append shadow "/sbin/nologin")))))
+
+(define* (oci-state->shepherd-services runtime runtime-cli containers networks volumes
+ #:key (user #f) (group #f) (verbose? #f)
+ (networks-name #f) (volumes-name #f)
+ (runtime-requirement '())
+ (networks-default-requirement '()))
+ (let* ((networks?
+ (> (length networks) 0))
+ (networks-requirement
+ (if networks?
+ (list
+ (string->symbol
+ (oci-networks-shepherd-name runtime)))
+ '()))
+ (volumes?
+ (> (length volumes) 0))
+ (volumes-requirement
+ (if volumes?
+ (list
+ (string->symbol
+ (oci-volumes-shepherd-name runtime)))
+ '())))
+ (append
+ (map
+ (lambda (c)
+ (oci-container-shepherd-service
+ runtime runtime-cli c
+ #:user user
+ #:group group
+ #:oci-requirement
+ (append networks-requirement volumes-requirement)
+ #:verbose? verbose?))
+ containers)
+ (if networks?
+ (list
+ (oci-networks-shepherd-service
+ runtime runtime-cli
+ (if (string? networks-name)
+ networks-name
+ (oci-networks-shepherd-name runtime))
+ networks
+ #:user user #:group group
+ #:default-requirement networks-default-requirement
+ #:runtime-requirement runtime-requirement
+ #:verbose? verbose?))
+ '())
+ (if volumes?
+ (list
+ (oci-volumes-shepherd-service runtime runtime-cli
+ (if (string? volumes-name)
+ volumes-name
+ (oci-volumes-shepherd-name runtime))
+ volumes
+ #:user user #:group group
+ #:runtime-requirement runtime-requirement
+ #:verbose? verbose?))
+ '()))))
+
+(define (oci-configuration->shepherd-services config)
+ (let* ((runtime (oci-configuration-runtime config))
+ (runtime-cli
+ (oci-runtime-system-cli config))
+ (containers (oci-configuration-containers config))
+ (networks (oci-configuration-networks config))
+ (volumes (oci-configuration-volumes config))
+ (user (oci-configuration-user config))
+ (group (oci-runtime-group
+ runtime (oci-configuration-group config)))
+ (verbose? (oci-configuration-verbose? config)))
+ (oci-state->shepherd-services runtime runtime-cli containers networks volumes
+ #:user user #:group group #:verbose? verbose?
+ #:runtime-requirement
+ (oci-runtime-system-requirement runtime))))
+
+(define (oci-service-subids config)
+ "Return a subids-extension record representing subuids and subgids required by
+the rootless Podman backend."
+ (define (delete-duplicate-ranges ranges)
+ (delete-duplicates ranges
+ (lambda args
+ (apply string=? (map subid-range-name ranges)))))
+ (define runtime
+ (oci-configuration-runtime config))
+ (define user
+ (oci-configuration-user config))
+ (define subgids (oci-configuration-subgids-range config))
+ (define subuids (oci-configuration-subuids-range config))
+ (define container-users
+ (filter (lambda (range) (not (string=? (subid-range-name range) user)))
+ (map (lambda (container)
+ (subid-range
+ (name
+ (oci-container-configuration-user container))))
+ (oci-configuration-containers config))))
+ (define subgid-ranges
+ (delete-duplicate-ranges
+ (cons
+ (if (maybe-value-set? subgids)
+ subgids
+ (subid-range (name user)))
+ container-users)))
+ (define subuid-ranges
+ (delete-duplicate-ranges
+ (cons
+ (if (maybe-value-set? subuids)
+ subuids
+ (subid-range (name user)))
+ container-users)))
+
+ (if (eq? 'podman runtime)
+ (subids-extension
+ (subgids
+ subgid-ranges)
+ (subuids
+ subuid-ranges))
+ (subids-extension)))
+
+(define (oci-objects-merge-lst a b object get-name)
+ (define (contains? value lst)
+ (member value (map get-name lst)))
+ (let loop ((merged '())
+ (lst (append a b)))
+ (if (null? lst)
+ merged
+ (loop
+ (let ((element (car lst)))
+ (when (contains? element merged)
+ (raise
+ (formatted-message
+ (G_ "Duplicated ~a: ~a. ~as names should be unique, please
+remove the duplicate.") object (get-name element) object)))
+ (cons element merged))
+ (cdr lst)))))
+
+(define (oci-extension-merge a b)
+ (oci-extension
+ (containers (oci-objects-merge-lst
+ (oci-extension-containers a)
+ (oci-extension-containers b)
+ "container"
+ (lambda (config)
+ (define maybe-name (oci-container-configuration-provision config))
+ (if (maybe-value-set? maybe-name)
+ maybe-name
+ (oci-image->container-name
+ (oci-container-configuration-image config))))))
+ (networks (oci-objects-merge-lst
+ (oci-extension-networks a)
+ (oci-extension-networks b)
+ "network"
+ oci-networks-shepherd-name))
+ (volumes (oci-objects-merge-lst
+ (oci-extension-volumes a)
+ (oci-extension-volumes b)
+ "volume"
+ oci-volumes-shepherd-name))))
+
+(define (oci-service-profile runtime runtime-cli)
+ (list bash-minimal
+ (cond
+ ((maybe-value-set? runtime-cli)
+ runtime-cli)
+ ((eq? 'podman runtime)
+ podman)
+ (else
+ docker-cli))))
+
+(define oci-service-type
+ (service-type (name 'oci)
+ (extensions
+ (list
+ (service-extension profile-service-type
+ (lambda (config)
+ (let ((runtime-cli
+ (oci-configuration-runtime-cli config))
+ (runtime
+ (oci-configuration-runtime config)))
+ (oci-service-profile runtime runtime-cli))))
+ (service-extension subids-service-type
+ oci-service-subids)
+ (service-extension account-service-type
+ oci-service-accounts)
+ (service-extension shepherd-root-service-type
+ oci-configuration->shepherd-services)))
+ ;; Concatenate OCI object lists.
+ (compose (lambda (args)
+ (fold oci-extension-merge
+ (oci-extension)
+ args)))
+ (extend
+ (lambda (config extension)
+ (oci-configuration
+ (inherit config)
+ (containers
+ (oci-objects-merge-lst
+ (oci-configuration-containers config)
+ (oci-extension-containers extension)
+ "container"
+ (lambda (oci-config)
+ (define runtime
+ (oci-configuration-runtime config))
+ (oci-container-shepherd-name runtime oci-config))))
+ (networks (oci-objects-merge-lst
+ (oci-configuration-networks config)
+ (oci-extension-networks extension)
+ "network"
+ oci-networks-shepherd-name))
+ (volumes (oci-objects-merge-lst
+ (oci-configuration-volumes config)
+ (oci-extension-volumes extension)
+ "volume"
+ oci-volumes-shepherd-name)))))
+ (default-value (oci-configuration))
+ (description
+ "This service implements the provisioning of OCI object such
+as containers, networks and volumes.")))
@@ -31,7 +31,10 @@ (define-module (gnu services docker)
#:use-module (gnu system shadow)
#:use-module (gnu packages docker)
#:use-module (gnu packages linux) ;singularity
+ #:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
#:use-module (guix gexp)
+ #:use-module (guix i18n)
#:use-module (guix records)
#:use-module (srfi srfi-1)
#:use-module (ice-9 format)
@@ -67,16 +70,18 @@ (define-module (gnu services docker)
oci-container-configuration-volumes
oci-container-configuration-container-user
oci-container-configuration-workdir
- oci-container-configuration-extra-arguments
- oci-container-shepherd-service
- %oci-container-accounts)
+ oci-container-configuration-extra-arguments)
#:export (containerd-configuration
containerd-service-type
docker-configuration
docker-service-type
singularity-service-type
- oci-container-service-type))
+ ;; for backwards compatibility, until the
+ ;; oci-container-service-type is fully deprecated
+ oci-container-shepherd-service
+ oci-container-service-type
+ %oci-container-accounts))
(define-maybe file-like)
@@ -295,17 +300,25 @@ (define singularity-service-type
;;; OCI container.
;;;
-(define (configs->shepherd-services configs)
- (map oci-container-shepherd-service configs))
+;; for backwards compatibility, until the
+;; oci-container-service-type is fully deprecated
+(define-deprecated (oci-container-shepherd-service config)
+ oci-service-type
+ ((@ (gnu services containers) oci-container-shepherd-service)
+ 'docker config))
+(define %oci-container-accounts
+ (filter user-account? (oci-service-accounts (oci-configuration))))
(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)))
+ (extensions
+ (list (service-extension oci-service-type
+ (lambda (containers)
+ (warning
+ (G_
+ "'oci-container-service-type' is deprecated, use 'oci-service-type' instead~%"))
+ (oci-extension
+ (containers containers))))))
(default-value '())
(extend append)
(compose concatenate)
@@ -27,6 +27,9 @@ (define-module (gnu tests containers)
#:use-module (gnu services)
#:use-module (gnu services containers)
#:use-module (gnu services desktop)
+ #:use-module ((gnu services docker)
+ #:select (containerd-service-type
+ docker-service-type))
#:use-module (gnu services dbus)
#:use-module (gnu services networking)
#:use-module (gnu system)
@@ -39,7 +42,9 @@ (define-module (gnu tests containers)
#:use-module (guix profiles)
#:use-module ((guix scripts pack) #:prefix pack:)
#:use-module (guix store)
- #:export (%test-rootless-podman))
+ #:export (%test-rootless-podman
+ %test-oci-service-rootless-podman
+ %test-oci-service-docker))
(define %rootless-podman-os
@@ -345,3 +350,952 @@ (define %test-rootless-podman
(name "rootless-podman")
(description "Test rootless Podman service.")
(value (build-tarball&run-rootless-podman-test))))
+
+
+(define %guile-oci-image
+ (oci-image
+ (repository "guile")
+ (value
+ (specifications->manifest '("guile")))
+ (pack-options
+ '(#:symlinks (("/bin" -> "bin"))))))
+
+(define %oci-test-containers
+ (list
+ (oci-container-configuration
+ (provision "first")
+ (image %guile-oci-image)
+ (entrypoint "/bin/guile")
+ (network "my-network")
+ (command
+ '("-c" "(use-modules (web server))
+(define (handler request request-body)
+ (values '((content-type . (text/plain))) \"out of office\"))
+(run-server handler 'http `(#:addr ,(inet-pton AF_INET \"0.0.0.0\")))"))
+ (host-environment
+ '(("VARIABLE" . "value")))
+ (volumes
+ '(("my-volume" . "/my-volume")))
+ (extra-arguments
+ '("--env" "VARIABLE")))
+ (oci-container-configuration
+ (provision "second")
+ (image %guile-oci-image)
+ (entrypoint "/bin/guile")
+ (network "my-network")
+ (command
+ '("-c" "(let l ((c 300))(display c)(sleep 1)(when(positive? c)(l (- c 1))))"))
+ (volumes
+ '(("my-volume" . "/my-volume")
+ ("/shared.txt" . "/shared.txt:ro"))))))
+
+(define %oci-extension-test
+ (oci-extension
+ (networks
+ (list (oci-network-configuration (name "my-network"))))
+ (volumes
+ (list (oci-volume-configuration (name "my-volume"))))
+ (containers %oci-test-containers)))
+
+(define %oci-rootless-podman-os
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service dbus-root-service-type)
+ (service polkit-service-type)
+ (service elogind-service-type)
+ (service iptables-service-type)
+ (service rootless-podman-service-type)
+ (extra-special-file "/shared.txt"
+ (plain-file "shared.txt" "hello"))
+ (service oci-service-type
+ (oci-configuration
+ (runtime 'podman)
+ (verbose? #t)))
+ (simple-service 'oci-provisioning
+ oci-service-type
+ %oci-extension-test)))
+
+(define (run-rootless-podman-oci-service-test)
+ (define os
+ (marionette-operating-system
+ (operating-system-with-gc-roots
+ %oci-rootless-podman-os
+ (list))
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (volatile? #f)
+ (memory-size 1024)
+ (disk-image-size (* 3000 (expt 2 20)))
+ (port-forwardings '())))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (srfi srfi-11) (srfi srfi-64)
+ (gnu build marionette))
+
+ (define marionette
+ ;; Relax timeout to accommodate older systems and
+ ;; allow for pulling the image.
+ (make-marionette (list #$vm) #:timeout 60))
+ (define out-dir "/tmp")
+
+ (test-runner-current (system-test-runner #$output))
+ (test-begin "rootless-podman-oci-service")
+
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (wait-for-service 'user-processes))
+ marionette)
+
+ (test-assert "rootless-podman services started successfully"
+ (begin
+ (define (run-test)
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 match)
+ (ice-9 rdelim))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+ (let* ((bash
+ ,(string-append #$bash "/bin/bash"))
+ (response1
+ (slurp bash "-c"
+ (string-append "ls -la /sys/fs/cgroup | "
+ "grep -E ' \\./?$' | awk '{ print $4 }'")))
+ (response2 (slurp bash "-c"
+ (string-append "ls -l /sys/fs/cgroup/cgroup"
+ ".{procs,subtree_control,threads} | "
+ "awk '{ print $4 }' | sort -u"))))
+ (list (string-join response1 "\n") (string-join response2 "\n"))))
+ marionette))
+ ;; Allow services to come up on slower machines
+ (let loop ((attempts 0))
+ (if (= attempts 60)
+ (error "Services didn't come up after more than 60 seconds")
+ (if (equal? '("cgroup" "cgroup")
+ (run-test))
+ #t
+ (begin
+ (sleep 1)
+ (format #t "Services didn't come up yet, retrying with attempt ~a~%"
+ (+ 1 attempts))
+ (loop (+ 1 attempts))))))))
+
+ (test-assert "podman-volumes running"
+ (begin
+ (define (run-test)
+ (marionette-eval
+ `(begin
+ (use-modules (srfi srfi-1)
+ (ice-9 popen)
+ (ice-9 match)
+ (ice-9 rdelim))
+
+ (define (wait-for-file file)
+ ;; Wait until FILE shows up.
+ (let loop ((i 6))
+ (cond ((file-exists? file)
+ #t)
+ ((zero? i)
+ (error "file didn't show up" file))
+ (else
+ (pk 'wait-for-file file)
+ (sleep 1)
+ (loop (- i 1))))))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ
+ (list "sh" "-l" "-c"
+ (string-join
+ args
+ " "))))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (setgid (passwd:gid (getpwnam "oci-container")))
+ (setuid (passwd:uid (getpw "oci-container")))
+
+ (let ((response (slurp
+ "/run/current-system/profile/bin/podman"
+ "volume" "ls" "-n" "--format" "\"{{.Name}}\""
+ "|" "tr" "' '" "'\n'")))
+
+ (call-with-output-file (string-append ,out-dir "/response")
+ (lambda (port)
+ (display (string-join response "\n") port)))))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (cdr (waitpid pid))))
+
+ (wait-for-file (string-append ,out-dir "/response"))
+
+ (stable-sort
+ (slurp "cat" (string-append ,out-dir "/response"))
+ string<=?))
+ marionette))
+ ;; Allow services to come up on slower machines
+ (let loop ((attempts 0))
+ (if (= attempts 80)
+ (error "Service didn't come up after more than 80 seconds")
+ (if (equal? '("my-volume")
+ (run-test))
+ #t
+ (begin
+ (sleep 1)
+ (loop (+ 1 attempts))))))))
+
+ (test-assert "podman-networks running"
+ (begin
+ (define (run-test)
+ (marionette-eval
+ `(begin
+ (use-modules (srfi srfi-1)
+ (ice-9 popen)
+ (ice-9 match)
+ (ice-9 rdelim))
+
+ (define (wait-for-file file)
+ ;; Wait until FILE shows up.
+ (let loop ((i 6))
+ (cond ((file-exists? file)
+ #t)
+ ((zero? i)
+ (error "file didn't show up" file))
+ (else
+ (pk 'wait-for-file file)
+ (sleep 1)
+ (loop (- i 1))))))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ
+ (list "sh" "-l" "-c"
+ (string-join
+ args
+ " "))))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (setgid (passwd:gid (getpwnam "oci-container")))
+ (setuid (passwd:uid (getpw "oci-container")))
+
+ (let ((response (slurp
+ "/run/current-system/profile/bin/podman"
+ "network" "ls" "-n" "--format" "\"{{.Name}}\""
+ "|" "tr" "' '" "'\n'")))
+
+ (call-with-output-file (string-append ,out-dir "/response")
+ (lambda (port)
+ (display (string-join response "\n") port)))))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (cdr (waitpid pid))))
+
+ (wait-for-file (string-append ,out-dir "/response"))
+
+ (stable-sort
+ (slurp "cat" (string-append ,out-dir "/response"))
+ string<=?))
+ marionette))
+ ;; Allow services to come up on slower machines
+ (let loop ((attempts 0))
+ (if (= attempts 80)
+ (error "Service didn't come up after more than 80 seconds")
+ (if (equal? '("my-network" "podman")
+ (run-test))
+ #t
+ (begin
+ (sleep 1)
+ (loop (+ 1 attempts))))))))
+
+ (test-assert "first container running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (wait-for-service 'first #:timeout 120)
+ #t)
+ marionette))
+
+ (test-assert "second container running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (wait-for-service 'second #:timeout 120)
+ #t)
+ marionette))
+
+ (test-assert "passing host environment variables"
+ (begin
+ (define (run-test)
+ (marionette-eval
+ `(begin
+ (use-modules (srfi srfi-1)
+ (ice-9 popen)
+ (ice-9 match)
+ (ice-9 rdelim))
+
+ (define (wait-for-file file)
+ ;; Wait until FILE shows up.
+ (let loop ((i 60))
+ (cond ((file-exists? file)
+ #t)
+ ((zero? i)
+ (error "file didn't show up" file))
+ (else
+ (pk 'wait-for-file file)
+ (sleep 1)
+ (loop (- i 1))))))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ
+ (list "sh" "-l" "-c"
+ (string-join
+ args
+ " "))))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (setgid (passwd:gid (getpwnam "oci-container")))
+ (setuid (passwd:uid (getpw "oci-container")))
+
+ (let ((response (slurp
+ "/run/current-system/profile/bin/podman"
+ "exec" "first"
+ "/bin/guile" "-c" "'(display (getenv \"VARIABLE\"))'")))
+ (call-with-output-file (string-append ,out-dir "/response")
+ (lambda (port)
+ (display (string-join response "\n") port)))))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (cdr (waitpid pid))))
+
+ (wait-for-file (string-append ,out-dir "/response"))
+ (slurp "cat" (string-append ,out-dir "/response")))
+ marionette))
+ ;; Allow image to be loaded on slower machines
+ (let loop ((attempts 0))
+ (if (= attempts 180)
+ (error "Service didn't come up after more than 180 seconds")
+ (if (equal? (list "value")
+ (run-test))
+ #t
+ (begin
+ (sleep 1)
+ (loop (+ 1 attempts))))))))
+
+ (test-equal "mounting host files"
+ '("hello")
+ (marionette-eval
+ `(begin
+ (use-modules (srfi srfi-1)
+ (ice-9 popen)
+ (ice-9 match)
+ (ice-9 rdelim))
+
+ (define (wait-for-file file)
+ ;; Wait until FILE shows up.
+ (let loop ((i 60))
+ (cond ((file-exists? file)
+ #t)
+ ((zero? i)
+ (error "file didn't show up" file))
+ (else
+ (pk 'wait-for-file file)
+ (sleep 1)
+ (loop (- i 1))))))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ
+ (list "sh" "-l" "-c"
+ (string-join
+ args
+ " "))))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (setgid (passwd:gid (getpwnam "oci-container")))
+ (setuid (passwd:uid (getpw "oci-container")))
+
+ (let ((response (slurp
+ "/run/current-system/profile/bin/podman"
+ "exec" "second"
+ "/bin/guile" "-c" "'(begin (use-modules (ice-9 popen) (ice-9 rdelim))
+(display (call-with-input-file \"/shared.txt\" read-line)))'")))
+ (call-with-output-file (string-append ,out-dir "/response")
+ (lambda (port)
+ (display (string-join response " ") port)))))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (cdr (waitpid pid))))
+
+ (wait-for-file (string-append ,out-dir "/response"))
+ (slurp "cat" (string-append ,out-dir "/response")))
+ marionette))
+
+ (test-equal "write to volumes"
+ '("world")
+ (marionette-eval
+ `(begin
+ (use-modules (srfi srfi-1)
+ (ice-9 popen)
+ (ice-9 match)
+ (ice-9 rdelim))
+
+ (define (wait-for-file file)
+ ;; Wait until FILE shows up.
+ (let loop ((i 60))
+ (cond ((file-exists? file)
+ #t)
+ ((zero? i)
+ (error "file didn't show up" file))
+ (else
+ (pk 'wait-for-file file)
+ (sleep 1)
+ (loop (- i 1))))))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ
+ (list "sh" "-l" "-c"
+ (string-join
+ args
+ " "))))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (setgid (passwd:gid (getpwnam "oci-container")))
+ (setuid (passwd:uid (getpw "oci-container")))
+
+ (slurp
+ "/run/current-system/profile/bin/podman"
+ "exec" "first"
+ "/bin/guile" "-c" "'(begin (use-modules (ice-9 popen) (ice-9 rdelim))
+(call-with-output-file \"/my-volume/out.txt\" (lambda (p) (display \"world\" p))))'")
+
+ (let ((response (slurp
+ "/run/current-system/profile/bin/podman"
+ "exec" "second"
+ "/bin/guile" "-c" "'(begin (use-modules (ice-9 popen) (ice-9 rdelim))
+(display (call-with-input-file \"/my-volume/out.txt\" read-line)))'")))
+ (call-with-output-file (string-append ,out-dir "/response")
+ (lambda (port)
+ (display (string-join response " ") port)))))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (cdr (waitpid pid))))
+
+ (wait-for-file (string-append ,out-dir "/response"))
+ (slurp "cat" (string-append ,out-dir "/response")))
+ marionette))
+
+ (test-equal "can read ports over network"
+ '("out of office")
+ (marionette-eval
+ `(begin
+ (use-modules (srfi srfi-1)
+ (ice-9 popen)
+ (ice-9 match)
+ (ice-9 rdelim))
+
+ (define (wait-for-file file)
+ ;; Wait until FILE shows up.
+ (let loop ((i 60))
+ (cond ((file-exists? file)
+ #t)
+ ((zero? i)
+ (error "file didn't show up" file))
+ (else
+ (pk 'wait-for-file file)
+ (sleep 1)
+ (loop (- i 1))))))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ
+ (list "sh" "-l" "-c"
+ (string-join
+ args
+ " "))))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (setgid (passwd:gid (getpwnam "oci-container")))
+ (setuid (passwd:uid (getpw "oci-container")))
+
+ (let ((response (slurp
+ "/run/current-system/profile/bin/podman"
+ "exec" "second"
+ "/bin/guile" "-c" "'(begin (use-modules (web client))
+(define-values (response out)
+ (http-get \"http://first:8080\"))
+(display out))'")))
+ (call-with-output-file (string-append ,out-dir "/response")
+ (lambda (port)
+ (display (string-join response " ") port)))))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (cdr (waitpid pid))))
+
+ (wait-for-file (string-append ,out-dir "/response"))
+ (slurp "cat" (string-append ,out-dir "/response")))
+ marionette))
+
+ (test-end))))
+
+ (gexp->derivation "rootless-podman-oci-service-test" test))
+
+(define %test-oci-service-rootless-podman
+ (system-test
+ (name "oci-service-rootless-podman")
+ (description "Test Rootless-Podman backed OCI provisioning service.")
+ (value (run-rootless-podman-oci-service-test))))
+
+(define %oci-docker-os
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service dbus-root-service-type)
+ (service polkit-service-type)
+ (service elogind-service-type)
+ (service containerd-service-type)
+ (service docker-service-type)
+ (extra-special-file "/shared.txt"
+ (plain-file "shared.txt" "hello"))
+ (service oci-service-type
+ (oci-configuration
+ (verbose? #t)))
+ (simple-service 'oci-provisioning
+ oci-service-type
+ %oci-extension-test)))
+
+(define (run-docker-oci-service-test)
+ (define os
+ (marionette-operating-system
+ (operating-system-with-gc-roots
+ %oci-docker-os
+ (list))
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (volatile? #f)
+ (memory-size 1024)
+ (disk-image-size (* 3000 (expt 2 20)))
+ (port-forwardings '())))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (srfi srfi-11) (srfi srfi-64)
+ (gnu build marionette))
+
+ (define marionette
+ ;; Relax timeout to accommodate older systems and
+ ;; allow for pulling the image.
+ (make-marionette (list #$vm) #:timeout 60))
+
+ (test-runner-current (system-test-runner #$output))
+ (test-begin "docker-oci-service")
+
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (wait-for-service 'dockerd))
+ marionette)
+
+ (test-assert "docker-volumes running"
+ (begin
+ (define (run-test)
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 rdelim))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ
+ (list "sh" "-l" "-c"
+ (string-join
+ args
+ " "))))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+
+ (stable-sort
+ (slurp
+ "/run/current-system/profile/bin/docker"
+ "volume" "ls" "--format" "\"{{.Name}}\"")
+ string<=?))
+
+ marionette))
+ ;; Allow services to come up on slower machines
+ (let loop ((attempts 0))
+ (if (= attempts 80)
+ (error "Service didn't come up after more than 80 seconds")
+ (if (equal? '("my-volume")
+ (run-test))
+ #t
+ (begin
+ (sleep 1)
+ (loop (+ 1 attempts))))))))
+
+ (test-assert "docker-networks running"
+ (begin
+ (define (run-test)
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 rdelim))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ
+ (list "sh" "-l" "-c"
+ (string-join
+ args
+ " "))))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+
+ (stable-sort
+ (slurp
+ "/run/current-system/profile/bin/docker"
+ "network" "ls" "--format" "\"{{.Name}}\"")
+ string<=?))
+
+ marionette))
+ ;; Allow services to come up on slower machines
+ (let loop ((attempts 0))
+ (if (= attempts 80)
+ (error "Service didn't come up after more than 80 seconds")
+ (if (equal? '("bridge" "host" "my-network" "none")
+ (run-test))
+ #t
+ (begin
+ (sleep 1)
+ (loop (+ 1 attempts))))))))
+
+ (test-assert "first container running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (wait-for-service 'first #:timeout 120)
+ #t)
+ marionette))
+
+ (test-assert "second container running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (wait-for-service 'second #:timeout 120)
+ #t)
+ marionette))
+
+ (test-assert "passing host environment variables"
+ (begin
+ (define (run-test)
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 rdelim))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (let ((line (read-line port)))
+ (if (eof-object? line)
+ ""
+ line)))
+ (status (close-pipe port)))
+ output)))
+
+ (slurp
+ "/run/current-system/profile/bin/docker"
+ "exec" "first"
+ "/bin/guile" "-c" "(display (getenv \"VARIABLE\"))"))
+ marionette))
+ ;; Allow image to be loaded on slower machines
+ (let loop ((attempts 0))
+ (if (= attempts 180)
+ (error "Service didn't come up after more than 180 seconds")
+ (if (equal? "value"
+ (run-test))
+ #t
+ (begin
+ (sleep 1)
+ (loop (+ 1 attempts))))))))
+
+ (test-equal "mounting host files"
+ "hello"
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 rdelim))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (let ((line (read-line port)))
+ (if (eof-object? line)
+ ""
+ line)))
+ (status (close-pipe port)))
+ output)))
+
+ (slurp
+ "/run/current-system/profile/bin/docker"
+ "exec" "second"
+ "/bin/guile" "-c" "(begin (use-modules (ice-9 popen) (ice-9 rdelim))
+(display (call-with-input-file \"/shared.txt\" read-line)))"))
+ marionette))
+
+ (test-equal "write to volumes"
+ "world"
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 rdelim))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (let ((line (read-line port)))
+ (if (eof-object? line)
+ ""
+ line)))
+ (status (close-pipe port)))
+ output)))
+
+ (slurp
+ "/run/current-system/profile/bin/docker"
+ "exec" "first"
+ "/bin/guile" "-c" "(begin (use-modules (ice-9 popen) (ice-9 rdelim))
+(call-with-output-file \"/my-volume/out.txt\" (lambda (p) (display \"world\" p))))")
+ (slurp
+ "/run/current-system/profile/bin/docker"
+ "exec" "second"
+ "/bin/guile" "-c" "(begin (use-modules (ice-9 popen) (ice-9 rdelim))
+(display (call-with-input-file \"/my-volume/out.txt\" read-line)))"))
+ marionette))
+
+ (test-equal "can read ports over network"
+ "out of office"
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 rdelim))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (let ((line (read-line port)))
+ (if (eof-object? line)
+ ""
+ line)))
+ (status (close-pipe port)))
+ output)))
+
+ (slurp
+ "/run/current-system/profile/bin/docker"
+ "exec" "second"
+ "/bin/guile" "-c" "(begin (use-modules (web client))
+(define-values (response out)
+ (http-get \"http://first:8080\"))
+(display out))"))
+ marionette))
+
+ (test-end))))
+
+ (gexp->derivation "docker-oci-service-test" test))
+
+(define %test-oci-service-docker
+ (system-test
+ (name "oci-service-docker")
+ (description "Test Docker backed OCI provisioning service.")
+ (value (run-docker-oci-service-test))))