tests: Use lower-oci-image-state in container tests.

This patch replaces boilerplate in container related tests with
oci-image plumbing from (gnu services containers).

* gnu/tests/containers.scm (%oci-tarball): New variable;
(run-rootless-podman-test): use %oci-tarball;
(build-tarball&run-rootless-podman-test): drop procedure.
* gnu/tests/docker.scm (%docker-tarball): New variable;
(build-tarball&run-docker-test): use %docker-tarball;
(%docker-system-tarball): New variable;
(build-tarball&run-docker-system-test): new procedure.

Change-Id: Iad6f0704aee188d89464c83722dea0bb7adb084a
Signed-off-by: Maxim Cournoyer <maxim@guixotic.coop>

2 files changed, 101 insertions, 87 deletions

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