diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/build/oci-containers.scm | 210 | ||||
| -rw-r--r-- | gnu/local.mk | 1 | ||||
| -rw-r--r-- | gnu/services/containers.scm | 1339 | ||||
| -rw-r--r-- | gnu/services/docker.scm | 38 | ||||
| -rw-r--r-- | gnu/tests/containers.scm | 561 |
5 files changed, 1947 insertions, 202 deletions
diff --git a/gnu/build/oci-containers.scm b/gnu/build/oci-containers.scm new file mode 100644 index 00000000000..38704e9e4a4 --- /dev/null +++ b/gnu/build/oci-containers.scm @@ -0,0 +1,210 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Giacomo Leidi <goodoldpaul@autistici.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; This module contains helpers used as part of the oci-service-type +;;; definition. +;;; +;;; Code: + +(define-module (gnu build oci-containers) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-1) + #:export (oci-read-lines + oci-system* + oci-object-exists? + oci-object-service-available? + oci-image-load + oci-log-verbose + oci-container-execlp + oci-object-create)) + +(define* (oci-read-lines invocation #:key verbose?) + (define (get-lines port) + (let ((lines-string (get-string-all port))) + (string-split lines-string #\newline))) + + (define command + (string-join invocation " ")) + + (when verbose? (format #t "Running ~a~%" command)) + + (with-input-from-port (open-input-pipe command) + (lambda _ + (get-lines (current-input-port))))) + +(define* (oci-log-verbose invocation) + (format #t "Running in verbose mode... +Current user: ~a ~a +Current group: ~a ~a +Current directory: ~a~%" + (getuid) (passwd:name (getpwuid (getuid))) + (getgid) (group:name (getgrgid (getgid))) + (getcwd)) + + (format #t "Running~{ ~a~}~%" invocation)) + +(define* (oci-system* invocation #:key verbose?) + (when verbose? + (format #t "Running~{ ~a~}~%" invocation)) + + (let* ((status (apply system* invocation)) + (exit-code (status:exit-val status))) + (when verbose? + (format #t "Exit code: ~a~%" exit-code)) + status)) + +(define* (oci-object-member name objects + #:key verbose?) + + (define member? (member name objects)) + + (when (and verbose? (> (length objects) 0)) + (format #t "~a is ~apart of:~{ ~a~}~%" + name + (if member? "" "not ") + objects)) + member?) + +(define* (oci-object-list runtime-cli object + #:key verbose? + (format-string "{{.Name}}")) + + (define invocation + (list runtime-cli object "ls" "--format" + (string-append "\"" format-string "\""))) + + (filter + (lambda (name) + (not (string=? (string-trim name) ""))) + (oci-read-lines invocation #:verbose? verbose?))) + +(define* (docker-object-exist? runtime-cli object name + #:key verbose? + (format-string "{{.Name}}")) + + (define objects + (oci-object-list runtime-cli object + #:verbose? verbose? + #:format-string format-string)) + + (oci-object-member name objects #:verbose? verbose?)) + +(define* (podman-object-exist? runtime-cli object name #:key verbose?) + (let ((invocation (list runtime-cli object "exists" name))) + (define exit-code + (status:exit-val (oci-system* invocation #:verbose? verbose?))) + (equal? EXIT_SUCCESS exit-code))) + +(define* (oci-object-exists? runtime runtime-cli object name + #:key verbose? + (format-string "{{.Name}}")) + (if (eq? runtime 'podman) + (podman-object-exist? runtime-cli object name + #:verbose? verbose?) + (docker-object-exist? runtime-cli object name + #:verbose? verbose? + #:format-string format-string))) + +(define* (oci-object-service-available? runtime-cli object names + #:key verbose? + (format-string "{{.Name}}")) + "Whether NAMES are provisioned in the current OBJECT environment." + (define environment + (oci-object-list runtime-cli object + #:verbose? verbose? + #:format-string format-string)) + (when verbose? + (format #t "~a environment:~{ ~a~}~%" object environment)) + + (define available? + (every + (lambda (name) + (oci-object-member name environment #:verbose? verbose?)) + names)) + + (when verbose? + (format #t "~a service is~a available~%" object (if available? "" " not"))) + + available?) + +(define* (oci-image-load runtime runtime-cli tarball name tag + #:key verbose? + (format-string "{{.Repository}}:{{.Tag}}")) + (define load-invocation + (list runtime-cli "load" "-i" tarball)) + + (if (oci-object-exists? runtime runtime-cli "image" tag + #:verbose? verbose? + #:format-string format-string) + (format #t "~a image already exists, skipping.~%" tag) + (begin + (format #t "Loading image for ~a from ~a...~%" name tarball) + + (let ((line (first + (oci-read-lines load-invocation #:verbose? verbose?)))) + (unless (or (eof-object? line) + (string-null? line)) + + (format #t "~a~%" line) + + (let* ((repository&tag + (string-drop line + (string-length + "Loaded image: "))) + (tag-invocation + (list runtime-cli "tag" repository&tag tag)) + (drop-old-tag-invocation + (list runtime-cli "image" "rm" "-f" repository&tag))) + + (unless (string=? repository&tag tag) + (let ((exit-code + (status:exit-val + (oci-system* tag-invocation #:verbose? verbose?)))) + (format #t "Tagged ~a with ~a...~%" tarball tag) + + (when (equal? EXIT_SUCCESS exit-code) + (oci-system* drop-old-tag-invocation #:verbose? verbose?)))))))))) + +(define* (oci-container-execlp invocation #:key verbose? pre-script) + (when pre-script + (pre-script)) + (when verbose? + (oci-log-verbose invocation)) + (apply execlp (first invocation) invocation)) + +(define* (oci-object-create runtime runtime-cli runtime-name + object + invocations + #:key verbose? + (format-string "{{.Name}}")) + (for-each + (lambda (invocation) + (define name (last invocation)) + (if (oci-object-exists? runtime runtime-cli object name + #:format-string format-string + #:verbose? verbose?) + (format #t "~a ~a ~a already exists, skipping creation.~%" + runtime-name name object) + (oci-system* invocation #:verbose? verbose?))) + invocations)) diff --git a/gnu/local.mk b/gnu/local.mk index 0bc93651997..74a85cad369 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -837,6 +837,7 @@ GNU_SYSTEM_MODULES = \ %D%/build/linux-initrd.scm \ %D%/build/linux-modules.scm \ %D%/build/marionette.scm \ + %D%/build/oci-containers.scm \ %D%/build/secret-service.scm \ \ %D%/tests.scm \ diff --git a/gnu/services/containers.scm b/gnu/services/containers.scm index 24f31c756b8..c9eadea9b47 100644 --- a/gnu/services/containers.scm +++ b/gnu/services/containers.scm @@ -35,12 +35,15 @@ #:use-module (guix diagnostics) #:use-module (guix gexp) #:use-module (guix i18n) + #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix profiles) #:use-module ((guix scripts pack) #:prefix pack:) + #:use-module (guix records) #: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 +99,82 @@ 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-runtime? + oci-runtime-system-environment + oci-runtime-system-extra-arguments + oci-runtime-system-requirement + oci-runtime-cli + oci-runtime-system-cli + oci-runtime-home-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-runtime-extra-arguments + oci-configuration-user + oci-configuration-group + oci-configuration-containers + oci-configuration-networks + oci-configuration-volumes + oci-configuration-verbose? + oci-configuration-valid? + + oci-extension + oci-extension? + oci-extension-fields + oci-extension-containers + oci-extension-networks + oci-extension-volumes + + oci-container-shepherd-name + oci-networks-shepherd-name + oci-networks-home-shepherd-name + oci-volumes-shepherd-name + oci-volumes-home-shepherd-name + + oci-container-configuration->options + oci-network-configuration->options + oci-volume-configuration->options + oci-container-shepherd-service - %oci-container-accounts)) + oci-objects-merge-lst + oci-extension-merge + oci-service-type + oci-service-accounts + oci-service-profile + oci-service-subids + oci-configuration->shepherd-services + oci-configuration-extend)) (define (gexp-or-string? value) (or (gexp? value) @@ -296,9 +373,42 @@ to be shared. This service sets it so.") ;;; -;;; 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 user-processes) + '(dockerd user-processes))) + +(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-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))) + (symbol? value)) + (define (oci-sanitize-pair pair delimiter) (define (valid? member) (or (string? member) @@ -332,21 +442,41 @@ found!") ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java") (oci-sanitize-mixed-list "host-environment" value "=")) +(define (oci-container-host-environment? value) + (list? (oci-sanitize-host-environment value))) + (define (oci-sanitize-environment value) ;; Expected spec format: ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java") (oci-sanitize-mixed-list "environment" value "=")) +(define (oci-container-environment? value) + (list? (oci-sanitize-environment value))) + (define (oci-sanitize-ports value) ;; Expected spec format: ;; '(("8088" . "80") "2022:22") (oci-sanitize-mixed-list "ports" value ":")) +(define (oci-container-ports? value) + (list? (oci-sanitize-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 (oci-container-volumes? value) + (list? (oci-sanitize-volumes value))) + +(define (oci-sanitize-labels value) + ;; Expected spec format: + ;; '(("foo" . "bar") "foo=bar") + (oci-sanitize-mixed-list "labels" value "=")) + +(define (oci-object-labels? value) + (list? (oci-sanitize-labels value))) + (define (oci-sanitize-shepherd-actions value) (map (lambda (el) @@ -358,6 +488,9 @@ found!") but ~a was found") el)))) value)) +(define (oci-container-shepherd-actions? value) + (list? (oci-sanitize-shepherd-actions value))) + (define (oci-sanitize-extra-arguments value) (define (valid? member) (or (string? member) @@ -373,11 +506,19 @@ but ~a was found") el)))) but ~a was found") el)))) value)) +(define (oci-object-extra-arguments? value) + (list? (oci-sanitize-extra-arguments value))) + (define (oci-image-reference image) - (if (string? image) - image - (string-append (oci-image-repository image) - ":" (oci-image-tag image)))) + "Return a string OCI image reference representing IMAGE." + (define reference + (if (string? image) + image + (string-append (oci-image-repository image) + ":" (oci-image-tag image)))) + (if (> (length (string-split reference #\/)) 1) + reference + (string-append "localhost/" reference))) (define (oci-lowerable-image? image) (or (manifest? image) @@ -392,7 +533,19 @@ but ~a was found") el)))) (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 @@ -437,11 +590,15 @@ value will be ignored.") (define-configuration/no-serialization oci-container-configuration (user - (string "oci-container") - "The user under whose authority docker commands will be run.") + (maybe-string) + "The user name under whose authority OCI commands will be run. This field will +override the @code{user} field of @code{oci-configuration}.") (group - (string "docker") - "The group under whose authority docker commands will be run.") + (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. +This field will override the @code{group} field of @code{oci-configuration}.") (command (list-of-strings '()) "Overwrite the default command (@code{CMD}) of the image.") @@ -449,11 +606,11 @@ value will be ignored.") (maybe-string) "Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.") (host-environment - (list '()) + (oci-container-host-environment '()) "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: @@ -467,7 +624,7 @@ Pair members can be strings, gexps or file-like objects. Strings are passed directly to @code{make-forkexec-constructor}." (sanitizer oci-sanitize-host-environment)) (environment - (list '()) + (oci-container-environment '()) "Set environment variables inside the container. This can be a list of pairs or strings, even mixed: @@ -477,15 +634,16 @@ or strings, even mixed: @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) @@ -508,15 +666,15 @@ is @code{#f} the service has to be started manually with @command{herd start}.") "Whether to restart the service when it stops, for instance when the underlying process dies.") (shepherd-actions - (list '()) + (oci-container-shepherd-actions '()) "This is a list of @code{shepherd-action} records defining actions supported by the service." (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 '()) + (oci-container-ports '()) "Set the port or port ranges to expose from the spawned container. This can be a list of pairs or strings, even mixed: @@ -526,12 +684,13 @@ be a list of pairs or strings, even mixed: @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 '()) + (oci-container-volumes '()) "Set volume mappings for the spawned container. This can be a list of pairs or strings, even mixed: @@ -541,71 +700,342 @@ list of pairs or strings, even mixed: @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 '()) + (oci-object-extra-arguments '()) "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} invocation." (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 + (oci-object-labels '()) + "The list of labels that will be used to tag the current volume." + (sanitizer oci-sanitize-labels)) + (extra-arguments + (oci-object-extra-arguments '()) + "A list of strings, gexps or file-like objects that will be directly passed +to the @command{docker volume create} or @command{podman volume create} +invocation." + (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 + (oci-object-labels '()) + "The list of labels that will be used to tag the current volume." + (sanitizer oci-sanitize-labels)) + (extra-arguments + (oci-object-extra-arguments '()) + "A list of strings, gexps or file-like objects that will be directly passed +to the @command{docker network create} or @command{podman network create} +invocation." + (sanitizer oci-sanitize-extra-arguments))) + +(define (list-of-oci-networks? value) + (list-of-oci-records? "networks" oci-network-configuration? value)) + +(define (package-or-string? value) + (or (package? value) (string? value))) + +(define-maybe/no-serialization package-or-string) + +(define-configuration/no-serialization oci-configuration + (runtime + (oci-runtime 'docker) + "The OCI runtime to use to run commands. It can be either @code{'docker} or +@code{'podman}.") + (runtime-cli + (maybe-package-or-string) + "The OCI runtime command line to be installed in the system profile and used +to provision OCI resources, it can be either a package or a string representing +an absolute file name to the runtime binary entrypoint. 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.") + (runtime-extra-arguments + (list '()) + "A list of strings, gexps or file-like objects that will be placed +after each @command{docker} or @command{podman} invokation.") + (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. The use of the @code{oci-extension} record should +be preferred for most cases.") + (networks + (list-of-oci-networks '()) + "The list of @code{oci-network-configuration} records representing the +networks to provision. The use of the @code{oci-extension} record should +be preferred for most cases.") + (volumes + (list-of-oci-volumes '()) + "The list of @code{oci-volume-configuration} records representing the +volumes to provision. The use of the @code{oci-extension} record should +be preferred for most cases.") + (verbose? + (boolean #f) + "When true, additional output will be printed, allowing to better follow the +flow of execution.") + (home-service? + (boolean for-home?) + "This is an internal field denoting whether this configuration is used in a +Guix Home context, as opposed to the default Guix System context.")) -(define* (get-keyword-value args keyword #:key (default #f)) - (let ((kv (memq keyword args))) - (if (and kv (>= (length kv) 2)) - (cadr kv) - default))) +(define (oci-runtime-system-environment runtime user) + (if (eq? runtime 'podman) + (list + #~(string-append + "HOME=" (passwd:dir (getpwnam #$user)))) + #~())) + +(define (oci-runtime-cli runtime runtime-cli profile-directory) + "Return a gexp that, when lowered, evaluates to the of the OCI +runtime command requested by the user." + (if (string? runtime-cli) + ;; It is a user defined absolute file name. + runtime-cli + #~(string-append + #$(if (maybe-value-set? runtime-cli) + runtime-cli + profile-directory) + #$(if (eq? 'podman runtime) + "/bin/podman" + "/bin/docker")))) + +(define* (oci-runtime-system-cli config #:key (profile-directory "/run/current-system/profile")) + (let ((runtime-cli + (oci-configuration-runtime-cli config)) + (runtime + (oci-configuration-runtime config))) + (oci-runtime-cli runtime runtime-cli profile-directory))) + +(define (oci-runtime-home-cli config) + (let ((runtime-cli + (oci-configuration-runtime-cli config)) + (runtime + (oci-configuration-runtime config))) + (oci-runtime-cli runtime runtime-cli + (string-append (getenv "HOME") + "/.guix-home/profile")))) + +(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-command-line-shepherd-action object-name invocation entrypoint) + "Return a Shepherd action printing a given INVOCATION of an OCI command for the +given OBJECT-NAME." + (shepherd-action + (name 'command-line) + (documentation + (format #f "Prints ~a's OCI runtime command line invocation." + object-name)) + (procedure + #~(lambda _ + (format #t "Entrypoint:~%~a~%" #$entrypoint) + (format #t "Invocation:~%~a~%" #$invocation))))) + +(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-networks-home-shepherd-name runtime) + "Return the name of the OCI volumes provisioning Home Shepherd service based on +RUNTIME." + (string-append "home-" (oci-networks-shepherd-name runtime))) + +(define (oci-volumes-home-shepherd-name runtime) + "Return the name of the OCI volumes provisioning Home Shepherd service based on +RUNTIME." + (string-append "home-" (oci-volumes-shepherd-name runtime))) + +(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?) + (list (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?) + (list (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 (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 @@ -614,24 +1044,11 @@ to the @command{docker run} invokation." #:target target))) (return tarball))) -(define (lower-manifest name image target system) - (define value (oci-image-value image)) - (define options (oci-image-pack-options image)) - (define image-reference - (oci-image-reference image)) - (define image-tag - (let* ((extra-options - (get-keyword-value options #:extra-options)) - (image-tag-option - (and extra-options - (get-keyword-value extra-options #:image-tag)))) - (if image-tag-option - '() - `(#:extra-options (#:image-tag ,image-reference))))) - +(define (lower-manifest name value options image-reference + target system grafts?) + "Lower VALUE, a manifest record, into a tarball containing an OCI image." (mlet* %store-monad - ((_ (set-grafting - (oci-image-grafts? image))) + ((_ (set-grafting grafts?)) (guile (set-guile-for-build (default-guile))) (profile (profile-derivation value @@ -642,14 +1059,11 @@ to the @command{docker run} invokation." (tarball (apply pack:docker-image `(,name ,profile ,@options - ,@image-tag #:localstatedir? #t)))) (return tarball))) -(define (lower-oci-image name image) - (define value (oci-image-value image)) - (define image-target (oci-image-target image)) - (define image-system (oci-image-system image)) +(define (lower-oci-image-state name value options reference + image-target image-system grafts?) (define target (if (maybe-value-set? image-target) image-target @@ -662,7 +1076,8 @@ to the @command{docker run} invokation." (run-with-store store (match value ((? manifest? value) - (lower-manifest name image target system)) + (lower-manifest name value options reference + target system grafts?)) ((? operating-system? value) (lower-operating-system value target system)) ((or (? gexp? value) @@ -677,113 +1092,661 @@ operating-system, gexp or file-like records but ~a was found") #: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))) - (with-imported-modules '((guix build utils)) - (program-file (format #f "~a-image-loader" name) - #~(begin - (use-modules (guix build utils) - (ice-9 popen) - (ice-9 rdelim)) +(define (lower-oci-image name image) + "Lower IMAGE, a oci-image record, into a tarball containing an OCI image." + (lower-oci-image-state + name + (oci-image-value image) + (oci-image-pack-options image) + (oci-image-reference image) + (oci-image-target image) + (oci-image-system image) + (oci-image-grafts? image))) + +(define-record-type* <oci-runtime-state> + oci-runtime-state + make-oci-runtime-state + oci-runtime-state? + this-oci-runtime-state - (format #t "Loading image for ~a from ~a...~%" #$name #$tarball) - (define line - (read-line - (open-input-pipe - (string-append #$docker " load -i " #$tarball)))) + (runtime oci-runtime-state-runtime + (default 'docker)) + (runtime-cli oci-runtime-state-runtime-cli) + (user oci-runtime-state-user) + (group oci-runtime-state-group) + (runtime-environment oci-runtime-state-runtime-environment + (default #~())) + (runtime-requirement oci-runtime-state-runtime-requirement + (default '())) + (runtime-extra-arguments oci-runtime-state-runtime-extra-arguments + (default '()))) - (unless (or (eof-object? line) - (string-null? line)) - (format #t "~a~%" line) - (let ((repository&tag - (string-drop line - (string-length - "Loaded image: ")))) +(define-record-type* <oci-state> + oci-state + make-oci-state + oci-state? + this-oci-state - (invoke #$docker "tag" repository&tag #$tag) - (format #t "Tagged ~a with ~a...~%" #$tarball #$tag)))))))) + (networks oci-state-networks) + (volumes oci-state-volumes) + (containers oci-state-containers) + (networks-name oci-state-networks-name + (default #f)) + (volumes-name oci-state-volumes-name + (default #f)) + (networks-requirement oci-state-networks-requirement + (default '())) + (volumes-requirement oci-state-volumes-requirement + (default '())) + (containers-requirement oci-state-containers-requirement + (default '()))) -(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)))))) +(define-record-type* <oci-container-invocation> + oci-container-invocation + make-oci-container-invocation + oci-container-invocation? + this-oci-container-invocation + + (runtime oci-container-invocation-runtime + (default 'docker)) + (runtime-cli oci-container-invocation-runtime-cli) + (name oci-container-invocation-name) + (command oci-container-invocation-command + (default '())) + (image-reference oci-container-invocation-image-reference) + (options oci-container-invocation-options + (default '())) + (run-extra-arguments oci-container-invocation-run-extra-arguments + (default '())) + (runtime-extra-arguments oci-container-invocation-runtime-extra-arguments + (default '()))) + +(define (oci-container-configuration->oci-container-invocation runtime-state + config) + (oci-container-invocation + (runtime (oci-runtime-state-runtime runtime-state)) + (runtime-cli (oci-runtime-state-runtime-cli runtime-state)) + (name + (oci-container-shepherd-name runtime config)) + (command + (oci-container-configuration-command config)) + (image-reference + (oci-image-reference (oci-container-configuration-image config))) + (options + (oci-container-configuration->options config)) + (run-extra-arguments + (oci-container-configuration-extra-arguments config)) + (runtime-extra-arguments + (oci-runtime-state-runtime-extra-arguments runtime-state)))) + +(define* (oci-image-loader runtime-state name image tag #:key verbose?) + "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 (source-module-closure '((gnu build oci-containers))) + (program-file + (format #f "~a-image-loader" name) + #~(begin + (use-modules (gnu build oci-containers)) + (oci-image-load '#$(oci-runtime-state-runtime runtime-state) + #$(oci-runtime-state-runtime-cli runtime-state) + #$tarball #$name #$tag + #:verbose? #$verbose?)))))) - (let* ((docker (file-append docker-cli "/bin/docker")) - (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)) - (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)) - (extra-arguments - (oci-container-configuration-extra-arguments config))) +(define (oci-container-run-invocation container-invocation) + "Return a list representing the OCI runtime +invocation for running containers." + ;; run [OPTIONS] IMAGE [COMMAND] [ARG...] + `(,(oci-container-invocation-runtime-cli container-invocation) + ,@(oci-container-invocation-runtime-extra-arguments container-invocation) + "run" "--rm" + ,@(if (eq? (oci-container-invocation-runtime container-invocation) + 'podman) + ;; This is because podman takes some time to + ;; release container names. --replace seems + ;; to be required to be able to restart services. + '("--replace") + '()) + "--name" ,(oci-container-invocation-name container-invocation) + ,@(oci-container-invocation-options container-invocation) + ,@(oci-container-invocation-run-extra-arguments container-invocation) + ,(oci-container-invocation-image-reference container-invocation) + ,@(oci-container-invocation-command container-invocation))) - (shepherd-service (provision `(,(string->symbol name))) - (requirement `(dockerd user-processes ,@requirement)) +(define* (oci-container-entrypoint name invocation + #:key verbose? + (pre-script #~())) + "Return a file-like object that, once lowered, will evaluate to the entrypoint +for the Shepherd service that will run INVOCATION." + (program-file + (string-append "oci-entrypoint-" name) + (with-imported-modules (source-module-closure + '((gnu build oci-containers))) + #~(begin + (use-modules (gnu build oci-containers) + (srfi srfi-1)) + (oci-container-execlp + (list #$@invocation) + #:verbose? #$verbose? + #:pre-script + (lambda _ + (when (and #$verbose? + (zero? (length '(#$@pre-script)))) + (format #t "No pre script to run...")) + #$@pre-script)))))) + +(define* (oci-container-shepherd-service state runtime-state config + #:key verbose? + networks? + volumes?) + "Return a Shepherd service object that will run the OCI container represented +by CONFIG through RUNTIME-CLI." + (match-record config <oci-container-configuration> + (shepherd-actions auto-start? user group host-environment + log-file requirement respawn? image) + (define runtime (oci-runtime-state-runtime runtime-state)) + (define runtime-cli (oci-runtime-state-runtime-cli runtime-state)) + (define image-reference (oci-image-reference image)) + (define shepherd-name (oci-container-shepherd-name runtime config)) + (define oci-container-user + (if (maybe-value-set? user) + user + (oci-runtime-state-user runtime-state))) + (define oci-container-group + (if (maybe-value-set? group) + group + (oci-runtime-state-group runtime-state))) + (define networks-service + (if networks? + (list + (string->symbol + (oci-state-networks-name state))) + '())) + (define volumes-service + (if volumes? + (list + (string->symbol + (oci-state-volumes-name state))) + '())) + (define oci-container-requirement + (append requirement + (oci-state-containers-requirement state) + (oci-runtime-state-runtime-requirement runtime-state) + networks-service + volumes-service)) + (define environment-variables + #~(append + (list #$@host-environment) + (list #$@(oci-runtime-state-runtime-environment runtime-state)))) + (define invocation + (oci-container-run-invocation + (oci-container-configuration->oci-container-invocation + runtime-state config))) + (define* (container-action command) + #~(lambda _ + (fork+exec-command + (list #$@command) + #$@(if oci-container-user + (list #:user oci-container-user) + '()) + #$@(if oci-container-group + (list #:group oci-container-group) + '()) + #$@(if (maybe-value-set? log-file) + (list #:log-file log-file) + '()) + #$@(if (and oci-container-user (eq? runtime 'podman)) + (list #:directory + #~(passwd:dir + (getpwnam #$oci-container-user))) + '()) + #:environment-variables + #$environment-variables))) + (define start-entrypoint + (oci-container-entrypoint + shepherd-name invocation + #:verbose? verbose? + #:pre-script + (if (oci-image? image) + #~((system* + #$(oci-image-loader + runtime-state shepherd-name image + image-reference + #:verbose? verbose?))) + #~()))) + + (shepherd-service (provision `(,(string->symbol shepherd-name))) + (requirement oci-container-requirement) (respawn? respawn?) (auto-start? auto-start?) (documentation (string-append - "Docker backed Shepherd service for " - (if (oci-image? image) name image) ".")) + (oci-runtime-name runtime) + " backed Shepherd service for " + (if (oci-image? image) shepherd-name image) ".")) (start - #~(lambda () - #$@(if (oci-image? image) - #~((invoke #$(%oci-image-loader - name image image-reference))) - #~()) - (fork+exec-command - ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...] - (list #$docker "run" "--rm" "--name" #$name - #$@options #$@extra-arguments - #$image-reference #$@command) - #:user #$user - #:group #$group - #$@(if (maybe-value-set? log-file) - (list #:log-file log-file) - '()) - #:environment-variables - (list #$@host-environment)))) + (container-action + (list start-entrypoint))) (stop - #~(lambda _ - (invoke #$docker "rm" "-f" #$name))) + (container-action + (list + (oci-container-entrypoint + shepherd-name (list runtime-cli "rm" "-f" shepherd-name) + #:verbose? verbose?)))) (actions - (if (oci-image? image) - '() - (append + (append + (list + (oci-command-line-shepherd-action + shepherd-name #~(string-join (list #$@invocation) " ") + start-entrypoint)) + (if (oci-image? image) + '() (list (shepherd-action (name 'pull) (documentation (format #f "Pull ~a's image (~a)." - name image)) + shepherd-name image)) (procedure - #~(lambda _ - (invoke #$docker "pull" #$image))))) - actions)))))) + (container-action + (list + (oci-container-entrypoint + shepherd-name (list runtime-cli "pull" image) + #:verbose? verbose?))))))) + shepherd-actions))))) + +(define (oci-object-create-invocation object runtime-cli name options + runtime-extra-arguments + create-extra-arguments) + "Return a gexp that, upon lowering, will evaluate to the OCI runtime +invocation for creating networks and volumes." + ;; network|volume create [options] [NAME] + #~(list #$runtime-cli #$@runtime-extra-arguments #$object "create" + #$@options #$@create-extra-arguments #$name)) -(define %oci-container-accounts +(define (format-oci-invocations invocations) + "Return a gexp that, upon lowering, will evaluate to a formatted message +containing the INVOCATIONS that the OCI runtime will execute to provision +networks or volumes." + #~(string-join (map (lambda (i) (string-join i " ")) + (list #$@invocations)) + "\n")) + +(define* (oci-object-create-script object runtime runtime-cli invocations + #:key verbose?) + "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)) + (define runtime-name (oci-runtime-name runtime)) + (with-imported-modules (source-module-closure + '((gnu build oci-containers))) + + (program-file + (string-append runtime-string "-" object "s-create.scm") + #~(begin + (use-modules (gnu build oci-containers)) + (oci-object-create '#$runtime #$runtime-cli #$runtime-name + #$object (list #$@invocations) + #:verbose? #$verbose?))))) + +(define* (oci-object-shepherd-service object runtime-state name + oci-state-requirement invocations + #:key verbose?) + "Return a Shepherd service object that will provision the OBJECTs represented +by INVOCATIONS through RUNTIME-STATE." + (match-record runtime-state <oci-runtime-state> + (runtime runtime-cli runtime-requirement user group + runtime-environment) + (define entrypoint + (oci-object-create-script + object runtime runtime-cli invocations #:verbose? verbose?)) + (define requirement + (append runtime-requirement oci-state-requirement)) + + (shepherd-service (provision (list (string->symbol name))) + (requirement requirement) + (one-shot? #t) + (documentation + (string-append + (oci-runtime-name runtime) " " object + " provisioning service")) + (start + #~(lambda _ + (fork+exec-command + (list #$entrypoint) + #$@(if user (list #:user user) '()) + #$@(if group (list #:group group) '()) + #:environment-variables + (list #$@runtime-environment)))) + (actions + (list + (oci-command-line-shepherd-action + name (format-oci-invocations invocations) + entrypoint)))))) + +(define* (oci-networks-shepherd-service state runtime-state + #:key verbose?) + "Return a Shepherd service object that will create the networks represented +in STATE." + (define runtime-cli + (oci-runtime-state-runtime-cli runtime-state)) + (define invocations + (map + (lambda (network) + (oci-object-create-invocation + "network" runtime-cli + (oci-network-configuration-name network) + (oci-network-configuration->options network) + (oci-runtime-state-runtime-extra-arguments runtime-state) + (oci-network-configuration-extra-arguments network))) + (oci-state-networks state))) + + (oci-object-shepherd-service + "network" runtime-state (oci-state-networks-name state) + (oci-state-networks-requirement state) + invocations #:verbose? verbose?)) + +(define* (oci-volumes-shepherd-service state runtime-state + #:key verbose?) + "Return a Shepherd service object that will create the volumes represented +in STATE." + (define runtime-cli + (oci-runtime-state-runtime-cli runtime-state)) + (define invocations + (map + (lambda (volume) + (oci-object-create-invocation + "volume" runtime-cli + (oci-volume-configuration-name volume) + (oci-volume-configuration->options volume) + (oci-runtime-state-runtime-extra-arguments runtime-state) + (oci-volume-configuration-extra-arguments volume))) + (oci-state-volumes state))) + + (oci-object-shepherd-service + "volume" runtime-state (oci-state-volumes-name state) + (oci-state-volumes-requirement state) + invocations #: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 state runtime-state #:key verbose?) + "Returns a list of Shepherd services based on the input OCI state." + (define networks? + (> (length (oci-state-networks state)) 0)) + (define volumes? + (> (length (oci-state-volumes state)) 0)) + (append + (map + (lambda (c) + (oci-container-shepherd-service + state runtime-state c + #:verbose? verbose? + #:volumes? volumes? + #:networks? networks?)) + (oci-state-containers state)) + (if networks? + (list + (oci-networks-shepherd-service + state runtime-state + #:verbose? verbose?)) + '()) + (if volumes? + (list + (oci-volumes-shepherd-service + state runtime-state + #:verbose? verbose?)) + '()))) + +(define* (oci-configuration->oci-runtime-state config #:key verbose?) + (define runtime + (oci-configuration-runtime config)) + (define home-service? + (oci-configuration-home-service? config)) + (define runtime-cli + (if home-service? + (oci-runtime-home-cli config) + (oci-runtime-system-cli config))) + (define user + (if home-service? + #f + (oci-configuration-user config))) + (define group + (if home-service? + #f + (if (eq? runtime 'podman) + #~(group:name + (getgrgid + (passwd:gid + (getpwnam #$user)))) + (oci-runtime-group config (oci-configuration-group config))))) + (define runtime-requirement + (if home-service? + '() + (oci-runtime-system-requirement runtime))) + (define runtime-environment + (if home-service? + #~() + (oci-runtime-system-environment runtime user))) + (oci-runtime-state + (runtime runtime) + (runtime-cli runtime-cli) + (user user) + (group group) + (runtime-extra-arguments + (oci-configuration-runtime-extra-arguments config)) + (runtime-environment runtime-environment) + (runtime-requirement runtime-requirement))) + +(define (oci-configuration->oci-state config) + (define runtime + (oci-configuration-runtime config)) + (define home-service? + (oci-configuration-home-service? config)) + (define networks-name + (if home-service? + (oci-networks-home-shepherd-name runtime) + (oci-networks-shepherd-name runtime))) + (define volumes-name + (if home-service? + (oci-volumes-home-shepherd-name runtime) + (oci-volumes-shepherd-name runtime))) + (define networks-requirement + (if home-service? + '() + '(networking))) + (oci-state + (containers (oci-configuration-containers config)) + (networks (oci-configuration-networks config)) + (volumes (oci-configuration-volumes config)) + (networks-name networks-name) + (volumes-name volumes-name) + (networks-requirement networks-requirement))) + +(define (oci-configuration->shepherd-services config) + (let* ((verbose? (oci-configuration-verbose? config)) + (state (oci-configuration->oci-state config)) + (runtime-state + (oci-configuration->oci-runtime-state config #:verbose? verbose?))) + (oci-state->shepherd-services state runtime-state #:verbose? verbose?))) + +(define (oci-service-subids config) + "Return a subids-extension record representing subuids and subgids required by +the rootless Podman backend." + (define (find-duplicates subids) + (let loop ((names '()) + (subids subids)) + (if (null? names) + names + (loop + (let ((name (subid-range-name (car subids)))) + (if (member name names) + (raise + (formatted-message + (G_ "Duplicated subid-range: ~a. subid-ranges names should be +unique, please remove the duplicate.") name)) + (cons name names))) + (cdr subids))))) + + (define runtime + (oci-configuration-runtime config)) + (define user + (oci-configuration-user config)) + + (define subgids (oci-configuration-subgids-range config)) + (find-duplicates subgids) + + (define subuids (oci-configuration-subuids-range config)) + (find-duplicates subgids) + + (define container-users + (filter (lambda (range) + (and (maybe-value-set? + (subid-range-name 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 + (cons + (if (maybe-value-set? subgids) + subgids + (subid-range (name user))) + container-users)) + (define subuid-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. Names of ~a 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-network-configuration-name)) + (volumes (oci-objects-merge-lst + (oci-extension-volumes a) + (oci-extension-volumes b) + "volume" + oci-volume-configuration-name)))) + +(define (oci-service-profile runtime runtime-cli) + `(,bash-minimal + ,@(if (string? runtime-cli) + '() + (list + (cond + ((maybe-value-set? runtime-cli) + runtime-cli) + ((eq? 'podman runtime) + podman) + (else + docker-cli)))))) + +(define (oci-configuration-extend 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-network-configuration-name)) + (volumes (oci-objects-merge-lst + (oci-configuration-volumes config) + (oci-extension-volumes extension) + "volume" + oci-volume-configuration-name)))) + +(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 oci-configuration-extend) + (default-value (oci-configuration)) + (description + "This service implements the provisioning of OCI objects such +as containers, networks and volumes."))) diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm index 828ceea313a..6abfbc49a0b 100644 --- a/gnu/services/docker.scm +++ b/gnu/services/docker.scm @@ -31,7 +31,10 @@ #: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 @@ 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) @@ -297,17 +302,26 @@ bundles in Docker containers.") ;;; 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) diff --git a/gnu/tests/containers.scm b/gnu/tests/containers.scm index 618da2a92ce..1a442cddc64 100644 --- a/gnu/tests/containers.scm +++ b/gnu/tests/containers.scm @@ -27,6 +27,9 @@ #: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 @@ #: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 @@ -133,7 +138,7 @@ (status (close-pipe port))) output))) (let* ((bash - ,(string-append #$bash "/bin/bash")) + (string-append #$bash "/bin/bash")) (response1 (slurp bash "-c" (string-append "ls -la /sys/fs/cgroup | " @@ -345,3 +350,555 @@ standard output device and then enters a new line.") (name "rootless-podman") (description "Test rootless Podman service.") (value (build-tarball&run-rootless-podman-test)))) + + +(define %oci-network + (oci-network-configuration (name "my-network"))) + +(define %oci-volume + (oci-volume-configuration (name "my-volume"))) + +(define %oci-wait-for-file + #~(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 %oci-read-lines + #~(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 %oci-slurp + #~(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)))) + +(define (%oci-rootless-podman-run commands) + #~((use-modules (srfi srfi-1) + (ice-9 format) + (ice-9 popen) + (ice-9 match) + (ice-9 rdelim) + (gnu build oci-containers)) + + #$%oci-wait-for-file + #$%oci-read-lines + #$%oci-slurp + + (define responses + (map + (lambda (index) + (format #f "/tmp/response_~a" index)) + (iota (length '#$commands)))) + + (match (primitive-fork) + (0 + (begin + (setgid (passwd:gid (getpwnam "oci-container"))) + (setuid (passwd:uid (getpw "oci-container"))) + + (let* ((outputs + (list #$@commands)) + (outputs-responses + (zip outputs responses))) + (for-each + (match-lambda + ((output response) + (call-with-output-file response + (lambda (port) + (display (string-join output "\n") port))))) + outputs-responses)))) + (pid + (cdr (waitpid pid)))) + + (for-each wait-for-file responses) + (map + (lambda (response) + (sort (slurp "cat" response) string<=?)) + responses))) + +(define %oci-rootless-podman-os + (simple-operating-system + (service dhcpcd-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 + (networks + (list %oci-network)) + (volumes + (list %oci-volume)) + (containers + (list + (oci-container-configuration + (provision "first") + (image + (oci-image + (repository "guile") + (value + (specifications->manifest '("guile"))) + (pack-options + '(#:symlinks (("/bin" -> "bin")))))) + (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 + (oci-image + (repository "guile") + (value + (specifications->manifest '("guile"))) + (pack-options + '(#:symlinks (("/bin" -> "bin")))))) + (entrypoint "/bin/guile") + (network "my-network") + (command + '("-c" "(let l ((c 300)) +(display c) +(newline) +(sleep 1) +(when (positive? c) + (l (- c 1))))")) + (volumes + '(("my-volume" . "/my-volume") + ("/shared.txt" . "/shared.txt:ro")))))))))) + +(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 build oci-containers) + (gnu build dbus-service) + (gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (volatile? #f) + (memory-size 1024) + (disk-image-size (* 5000 (expt 2 20))) + (port-forwardings '()))) + + (define test + (with-imported-modules '((gnu build oci-containers) + (gnu build dbus-service) + (gnu build marionette)) + #~(begin + (use-modules (srfi srfi-1) (srfi srfi-11) (srfi srfi-64) + (gnu build dbus-service) + (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 "rootless-podman-oci-service") + + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (wait-for-service 'user-processes)) + marionette) + + (test-assert "podman-volumes running" + (begin + (define (run-test) + (first + (marionette-eval + `(begin + #$@(%oci-rootless-podman-run + #~((oci-object-service-available? + "/run/current-system/profile/bin/podman" + "volume" + '("my-volume") + #:verbose? #t)))) + marionette))) + ;; Allow services to come up on slower machines. + (with-retries 80 1 (equal? '("my-volume") (run-test))))) + + (test-assert "podman-networks running" + (begin + (define (run-test) + (first + (marionette-eval + `(begin + #$@(%oci-rootless-podman-run + #~((oci-object-service-available? + "/run/current-system/profile/bin/podman" + "network" + '("my-network") + #:verbose? #t)))) + marionette))) + ;; Allow services to come up on slower machines. + (with-retries 80 1 (equal? '("my-network" "podman") (run-test))))) + + (test-assert "image loaded" + (begin + (define (run-test) + (first + (marionette-eval + `(begin + #$@(%oci-rootless-podman-run + #~((oci-object-service-available? + "/run/current-system/profile/bin/podman" + "image" + '("localhost/guile:latest") + #:format-string "{{.Repository}}:{{.Tag}}" + #:verbose? #t)))) + marionette))) + ;; Allow services to come up on slower machines. + (with-retries 80 1 + (equal? + '("localhost/guile:latest") + (run-test))))) + + (test-assert "passing host environment variables" + (begin + (define (run-test) + (first + (marionette-eval + `(begin + #$@(%oci-rootless-podman-run + #~((slurp + "/run/current-system/profile/bin/podman" + "exec" "first" + "/bin/guile" "-c" + "'(display (getenv \"VARIABLE\"))'")))) + marionette))) + ;; Allow services to come up on slower machines. + (with-retries 80 1 (equal? '("value") (run-test))))) + + (test-equal "mounting host files" + '("hello") + (first + (marionette-eval + `(begin + #$@(%oci-rootless-podman-run + #~((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)))'")))) + marionette))) + + (test-equal "read and write to provisioned volumes" + '("world") + (second + (marionette-eval + `(begin + #$@(%oci-rootless-podman-run + #~((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))))'") + (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)))'")))) + marionette))) + + (test-equal + "can read and write to ports over provisioned network" + '("out of office") + (first + (marionette-eval + `(begin + #$@(%oci-rootless-podman-run + #~((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))'")))) + 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-run commands) + #~((use-modules (srfi srfi-1) + (ice-9 format) + (ice-9 popen) + (ice-9 match) + (ice-9 rdelim) + (gnu build oci-containers)) + + #$%oci-read-lines + #$%oci-slurp + + (let ((outputs (list #$@commands))) + (map + (lambda (output) + (sort output string<=?)) + outputs)))) + +(define %oci-docker-os + (simple-operating-system + (service dhcpcd-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 + (networks + (list %oci-network)) + (volumes + (list %oci-volume)) + (containers + (list + (oci-container-configuration + (provision "first") + (image + (oci-image + (repository "guile") + (value + (specifications->manifest '("guile"))) + (pack-options + '(#:symlinks (("/bin" -> "bin")))))) + (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 + (oci-image + (repository "guile") + (value + (specifications->manifest '("guile"))) + (pack-options + '(#:symlinks (("/bin" -> "bin")))))) + (entrypoint "/bin/guile") + (network "my-network") + (command + '("-c" "(let l ((c 300)) +(display c) +(newline) +(sleep 1) +(when (positive? c) + (l (- c 1))))")) + (volumes + '(("my-volume" . "/my-volume") + ("/shared.txt" . "/shared.txt:ro")))))))))) + +(define (run-docker-oci-service-test) + (define os + (marionette-operating-system + (operating-system-with-gc-roots + %oci-docker-os + (list)) + #:imported-modules '((gnu build oci-containers) + (gnu build dbus-service) + (gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (volatile? #f) + (memory-size 1024) + (disk-image-size (* 5000 (expt 2 20))) + (port-forwardings '()))) + + (define test + (with-imported-modules '((gnu build oci-containers) + (gnu build dbus-service) + (gnu build marionette)) + #~(begin + (use-modules (srfi srfi-1) (srfi srfi-11) (srfi srfi-64) + (gnu build dbus-service) + (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) + (first + (marionette-eval + `(begin + #$@(%oci-docker-run + #~((oci-object-service-available? + "/run/current-system/profile/bin/docker" + "volume" + '("my-volume") + #:verbose? #t)))) + marionette))) + ;; Allow services to come up on slower machines. + (with-retries 80 1 (equal? '("my-volume") (run-test))))) + + (test-assert "docker-networks running" + (begin + (define (run-test) + (first + (marionette-eval + `(begin + #$@(%oci-docker-run + #~((oci-object-service-available? + "/run/current-system/profile/bin/docker" + "network" + '("my-network") + #:verbose? #t)))) + marionette))) + ;; Allow services to come up on slower machines. + (with-retries 80 1 (equal? + '("my-network" "none") + (run-test))))) + + (test-assert "passing host environment variables" + (begin + (define (run-test) + (first + (marionette-eval + `(begin + #$@(%oci-docker-run + #~((slurp + "/run/current-system/profile/bin/docker" + "exec" "first" + "/bin/guile" "-c" + "'(display (getenv \"VARIABLE\"))'")))) + marionette))) + ;; Allow services to come up on slower machines. + (with-retries 80 1 (equal? '("value") (run-test))))) + + (test-equal "read and write to provisioned volumes" + '("world") + (second + (marionette-eval + `(begin + #$@(%oci-docker-run + #~((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 and write to ports over provisioned network" + '("out of office") + (first + (marionette-eval + `(begin + #$@(%oci-docker-run + #~((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)))) |