M gnu/tests/containers.scm => gnu/tests/containers.scm +42 -42
@@ 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
M gnu/tests/docker.scm => gnu/tests/docker.scm +59 -45
@@ 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