Subject: [PATCH v6 4/5] tests: Use lower-oci-image-state in container tests.

From: Giacomo Leidi <[email-masked]>
Date: Thu, 27 Feb 2025 00:08:09 +0100

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

* gnu/services/containers.scm: Export lower-oci-image-state.
* 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
---
 gnu/services/containers.scm |   2 +
 gnu/tests/containers.scm    |  80 ++++++++++++++---------------
 gnu/tests/docker.scm        | 100 ++++++++++++++++++++----------------
 3 files changed, 95 insertions(+), 87 deletions(-)

diff --git a/gnu/services/containers.scm b/gnu/services/containers.scm
index 603eec25e2b..139d5e4ec50 100644
--- a/gnu/services/containers.scm
+++ b/gnu/services/containers.scm
@@ -75,6 +75,8 @@ (define-module (gnu services containers)
             oci-image-system
             oci-image-grafts?
 
+            lower-oci-image-state
+
             oci-container-configuration
             oci-container-configuration?
             oci-container-configuration-fields
diff --git a/gnu/tests/containers.scm b/gnu/tests/containers.scm
index 5e6f39387e7..8cdd86e7ae3 100644
--- a/gnu/tests/containers.scm
+++ b/gnu/tests/containers.scm
@@ -69,13 +69,47 @@ (define %rootless-podman-os
                           (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 `(#: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))))
+   '(#: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 +288,7 @@ (define (run-rootless-podman-test oci-tarball)
                        (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 +341,11 @@ (define (run-rootless-podman-test oci-tarball)
 
   (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-rootless-podman-os
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 5dcf05a17e3..07edd9d5341 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -26,6 +26,7 @@ (define-module (gnu tests docker)
   #: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)
@@ -57,6 +58,40 @@ (define %docker-os
    (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 `(#: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))))
+   '(#: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 +208,7 @@ (define (run-docker-test docker-tarball)
   (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 +217,22 @@ (define %test-docker
    (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 +349,15 @@ (define (run-docker-system-test tarball)
 
   (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
-- 
2.48.1