Package: guix-patches;
Reported by: paul <goodoldpaul <at> autistici.org>
Date: Wed, 5 Feb 2025 22:01:03 UTC
Severity: normal
Tags: moreinfo
View this message in rfc822 format
From: Giacomo Leidi <goodoldpaul <at> autistici.org> To: 76081 <at> debbugs.gnu.org Cc: Giacomo Leidi <goodoldpaul <at> autistici.org> Subject: [bug#76081] [PATCH v11 4/5] tests: Use lower-oci-image-state in container tests. Date: Sun, 1 Jun 2025 04:51:17 +0200
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: Giacomo Leidi <goodoldpaul <at> autistici.org>
---
gnu/tests/containers.scm | 84 +++++++++++++++----------------
gnu/tests/docker.scm | 104 ++++++++++++++++++++++-----------------
2 files changed, 101 insertions(+), 87 deletions(-)
diff --git a/gnu/tests/containers.scm b/gnu/tests/containers.scm
index 051a4c740bf..0db22e3a07f 100644
--- a/gnu/tests/containers.scm
+++ b/gnu/tests/containers.scm
@@ -46,6 +46,9 @@ (define-module (gnu tests containers)
%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 @@ (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
+ (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 @@ (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 +345,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-network
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 5dcf05a17e3..1f264d52486 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)
@@ -48,6 +49,9 @@ (define-module (gnu tests docker)
%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 dhcp-client-service-type)
@@ -57,6 +61,41 @@ (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
+ (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 @@ (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 +221,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 +353,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.49.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.