diff --git a/gnu/tests/containers.scm b/gnu/tests/containers.scm index 1a442cddc64..089303643c9 100644 --- a/gnu/tests/containers.scm +++ b/gnu/tests/containers.scm @@ -46,6 +46,9 @@ %test-oci-service-rootless-podman %test-oci-service-docker)) +(define lower-oci-image-state + (@@ (gnu services containers) lower-oci-image-state)) + (define %rootless-podman-os (simple-operating-system @@ -69,13 +72,48 @@ (supplementary-groups '("wheel" "netdev" "cgroup" "audio" "video"))))))) -(define (run-rootless-podman-test oci-tarball) +(define %oci-tarball + (lower-oci-image-state + "guile-guest" + (packages->manifest + (list + guile-3.0 guile-json-3 + (package + (name "guest-script") + (version "0") + (source #f) + (build-system trivial-build-system) + (arguments + (list + #:guile guile-3.0 + #:builder + #~(let ((out #$output)) + (mkdir out) + (call-with-output-file (string-append out "/a.scm") + (lambda (port) + (display "(display \"hello world\n\")" port)))))) + (synopsis "Display hello world using Guile") + (description "This package displays the text \"hello world\" on the +standard output device and then enters a new line.") + (home-page #f) + (license license:public-domain)))) + '(#:entry-point "bin/guile" + #:localstatedir? #t + #:extra-options (#:image-tag "guile-guest") + #:symlinks (("/bin/Guile" -> "bin/guile") + ("aa.scm" -> "a.scm"))) + "guile-guest" + (%current-target-system) + (%current-system) + #f)) + +(define (run-rootless-podman-test) (define os (marionette-operating-system (operating-system-with-gc-roots %rootless-podman-os - (list oci-tarball)) + (list %oci-tarball)) #:imported-modules '((gnu services herd) (guix combinators)))) @@ -254,7 +292,7 @@ (let* ((loaded (slurp ,(string-append #$podman "/bin/podman") "load" "-i" - ,#$oci-tarball)) + ,#$%oci-tarball)) (repository&tag "localhost/guile-guest:latest") (response1 (slurp ,(string-append #$podman "/bin/podman") @@ -307,49 +345,11 @@ (gexp->derivation "rootless-podman-test" test)) -(define (build-tarball&run-rootless-podman-test) - (mlet* %store-monad - ((_ (set-grafting #f)) - (guile (set-guile-for-build (default-guile))) - (guest-script-package -> - (package - (name "guest-script") - (version "0") - (source #f) - (build-system trivial-build-system) - (arguments `(#:guile ,guile-3.0 - #:builder - (let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (call-with-output-file (string-append out "/a.scm") - (lambda (port) - (display "(display \"hello world\n\")" port))) - #t))) - (synopsis "Display hello world using Guile") - (description "This package displays the text \"hello world\" on the -standard output device and then enters a new line.") - (home-page #f) - (license license:public-domain))) - (profile (profile-derivation (packages->manifest - (list guile-3.0 guile-json-3 - guest-script-package)) - #:hooks '() - #:locales? #f)) - (tarball (pack:docker-image - "docker-pack" profile - #:symlinks '(("/bin/Guile" -> "bin/guile") - ("aa.scm" -> "a.scm")) - #:extra-options - '(#:image-tag "guile-guest") - #:entry-point "bin/guile" - #:localstatedir? #t))) - (run-rootless-podman-test tarball))) - (define %test-rootless-podman (system-test (name "rootless-podman") (description "Test rootless Podman service.") - (value (build-tarball&run-rootless-podman-test)))) + (value (run-rootless-podman-test)))) (define %oci-network diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 9fee3905f0e..4fc50a99a72 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -26,6 +26,7 @@ #:use-module (gnu system image) #:use-module (gnu system vm) #:use-module (gnu services) + #:use-module (gnu services containers) #:use-module (gnu services dbus) #:use-module (gnu services networking) #:use-module (gnu services docker) @@ -48,6 +49,9 @@ %test-docker-system %test-oci-container)) +(define lower-oci-image-state + (@@ (gnu services containers) lower-oci-image-state)) + (define %docker-os (simple-operating-system (service dhcpcd-service-type) @@ -57,6 +61,41 @@ (service containerd-service-type) (service docker-service-type))) +(define %docker-tarball + (lower-oci-image-state + "guile-guest" + (packages->manifest + (list + guile-3.0 guile-json-3 + (package + (name "guest-script") + (version "0") + (source #f) + (build-system trivial-build-system) + (arguments + (list + #:guile guile-3.0 + #:builder + #~(let ((out #$output)) + (mkdir out) + (call-with-output-file (string-append out "/a.scm") + (lambda (port) + (display "(display \"hello world\n\")" port)))))) + (synopsis "Display hello world using Guile") + (description "This package displays the text \"hello world\" on the +standard output device and then enters a new line.") + (home-page #f) + (license license:public-domain)))) + '(#:entry-point "bin/guile" + #:localstatedir? #t + #:extra-options (#:image-tag "guile-guest") + #:symlinks (("/bin/Guile" -> "bin/guile") + ("aa.scm" -> "a.scm"))) + "guile-guest" + (%current-target-system) + (%current-system) + #f)) + (define (run-docker-test docker-tarball) "Load DOCKER-TARBALL as Docker image and run it in a Docker container, inside %DOCKER-OS." @@ -173,40 +212,7 @@ inside %DOCKER-OS." (gexp->derivation "docker-test" test)) (define (build-tarball&run-docker-test) - (mlet* %store-monad - ((_ (set-grafting #f)) - (guile (set-guile-for-build (default-guile))) - (guest-script-package -> - (package - (name "guest-script") - (version "0") - (source #f) - (build-system trivial-build-system) - (arguments `(#:guile ,guile-3.0 - #:builder - (let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (call-with-output-file (string-append out "/a.scm") - (lambda (port) - (display "(display \"hello world\n\")" port))) - #t))) - (synopsis "Display hello world using Guile") - (description "This package displays the text \"hello world\" on the -standard output device and then enters a new line.") - (home-page #f) - (license license:public-domain))) - (profile (profile-derivation (packages->manifest - (list guile-3.0 guile-json-3 - guest-script-package)) - #:hooks '() - #:locales? #f)) - (tarball (pack:docker-image - "docker-pack" profile - #:symlinks '(("/bin/Guile" -> "bin/guile") - ("aa.scm" -> "a.scm")) - #:entry-point "bin/guile" - #:localstatedir? #t))) - (run-docker-test tarball))) + (run-docker-test %docker-tarball)) (define %test-docker (system-test @@ -215,8 +221,22 @@ standard output device and then enters a new line.") (value (build-tarball&run-docker-test)))) +(define %docker-system-tarball + (lower-oci-image-state + "guix-system-guest" + (operating-system + (inherit (simple-operating-system)) + ;; Use locales for a single libc to + ;; reduce space requirements. + (locale-libcs (list glibc))) + '() + "guix-system-guest" + (%current-target-system) + (%current-system) + #f)) + (define (run-docker-system-test tarball) - "Load DOCKER-TARBALL as Docker image and run it in a Docker container, + "Load TARBALL as Docker image and run it in a Docker container, inside %DOCKER-OS." (define os (marionette-operating-system @@ -333,21 +353,15 @@ inside %DOCKER-OS." (gexp->derivation "docker-system-test" test)) +(define (build-tarball&run-docker-system-test) + (run-docker-system-test %docker-system-tarball)) + (define %test-docker-system (system-test (name "docker-system") (description "Run a system image as produced by @command{guix system docker-image} inside Docker.") - (value (with-monad %store-monad - (>>= (lower-object - (system-image (os->image - (operating-system - (inherit (simple-operating-system)) - ;; Use locales for a single libc to - ;; reduce space requirements. - (locale-libcs (list glibc))) - #:type docker-image-type))) - run-docker-system-test))))) + (value (build-tarball&run-docker-system-test)))) (define %oci-os