* [bug#34071] [PATCH] tests: docker: Run a guest guile inside the docker container.
@ 2019-01-14 14:35 Danny Milosavljevic
2019-01-14 14:46 ` [bug#34071] [PATCH v2] " Danny Milosavljevic
0 siblings, 1 reply; 5+ messages in thread
From: Danny Milosavljevic @ 2019-01-14 14:35 UTC (permalink / raw)
To: 34071
* gnu/tests/docker.scm (run-docker-test): Add parameters. Load
and run docker container. Check response of guest guile.
(build-tarball&run-docker-test): New proecedure.
(%test-docker): Use it.
[description]: Modify.
---
gnu/tests/docker.scm | 86 ++++++++++++++++++++++++++++++++++++++++----
1 file changed, 79 insertions(+), 7 deletions(-)
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 973a84c55..5c5a47210 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,4 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of GNU Guix.
@@ -26,11 +27,24 @@
#:use-module (gnu services networking)
#:use-module (gnu services docker)
#:use-module (gnu services desktop)
+ #:use-module (gnu packages bootstrap)
#:use-module (gnu packages docker)
+ #:use-module (guix derivations)
#:use-module (guix gexp)
+ #:use-module (guix grafts)
+ #:use-module (guix monads)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module (guix scripts pack)
#:use-module (guix store)
+ #:use-module (guix tests)
+ #:use-module (srfi srfi-64)
+ #:use-module (guix build-system trivial)
#:export (%test-docker))
+;; Globally disable grafts because they can trigger early builds.
+;(%graft? #f)
+
(define %docker-os
(simple-operating-system
(service dhcp-client-service-type)
@@ -39,8 +53,9 @@
(service elogind-service-type)
(service docker-service-type)))
-(define (run-docker-test)
- "Run tests in %DOCKER-OS."
+(define (run-docker-test docker-tarball)
+ "Load the DOCKER-TARBALL as docker image and run it in a Docker container,
+inside %DOCKER-OS."
(define os
(marionette-operating-system
%docker-os
@@ -50,15 +65,16 @@
(define vm
(virtual-machine
(operating-system os)
- (memory-size 500)
- (disk-image-size (* 250 (expt 2 20)))
+ (memory-size 1500)
+ (disk-image-size (* 1500 (expt 2 20)))
(port-forwardings '())))
(define test
(with-imported-modules '((gnu build marionette))
#~(begin
(use-modules (srfi srfi-11) (srfi srfi-64)
- (gnu build marionette))
+ (gnu build marionette)
+ (ice-9 regex))
(define marionette
(make-marionette (list #$vm)))
@@ -87,13 +103,69 @@
"version"))
marionette))
+ (test-equal "pack guest OS as docker image, load it and run it"
+ "hello world"
+ (marionette-eval
+ `(begin
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (read-line port))
+ (status (close-pipe port)))
+ output)))
+ (let* ((raw-text (slurp ,(string-append #$docker-cli
+ "/bin/docker")
+ "load" "-i"
+ ,#$docker-tarball))
+ (repository&tag (string-drop raw-text
+ (string-length
+ "Loaded image: ")))
+ (response (slurp
+ ,(string-append #$docker-cli "/bin/docker")
+ "run" "--entrypoint" "bin/Guile"
+ repository&tag
+ "/aa.scm")))
+ response))
+ marionette))
+
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(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 ->
+ (dummy-package "guest-script"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #: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)))))
+ (profile (profile-derivation (packages->manifest
+ (list %bootstrap-guile
+ guest-script-package))
+ #:hooks '()
+ #:locales? #f))
+ (tarball (docker-image "docker-pack" profile
+ #:symlinks '(("/bin/Guile" -> "bin/guile")
+ ("aa.scm" -> "a.scm"))
+ #:localstatedir? #t)))
+ (run-docker-test tarball)))
+
(define %test-docker
(system-test
(name "docker")
- (description "Connect to the running Docker service.")
- (value (run-docker-test))))
+ (description "Test Docker container of Guix.")
+ (value (build-tarball&run-docker-test))))
+
+;; Local Variables:
+;; eval: (put 'test-assertm 'scheme-indent-function 2)
+;; End:
^ permalink raw reply related [flat|nested] 5+ messages in thread
* [bug#34071] [PATCH v2] tests: docker: Run a guest guile inside the docker container.
2019-01-14 14:35 [bug#34071] [PATCH] tests: docker: Run a guest guile inside the docker container Danny Milosavljevic
@ 2019-01-14 14:46 ` Danny Milosavljevic
2019-01-14 16:32 ` [bug#34071] [PATCH v3] " Danny Milosavljevic
0 siblings, 1 reply; 5+ messages in thread
From: Danny Milosavljevic @ 2019-01-14 14:46 UTC (permalink / raw)
To: 34071
* gnu/tests/docker.scm (run-docker-test): Add parameters. Load and run
docker container. Check response of guest guile.
(build-tarball&run-docker-test): New procedure.
(%test-docker): Use it.
[description]: Modify.
---
gnu/tests/docker.scm | 82 ++++++++++++++++++++++++++++++++++++++++----
1 file changed, 76 insertions(+), 6 deletions(-)
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 453ed4893..ad574b758 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -26,11 +26,24 @@
#:use-module (gnu services networking)
#:use-module (gnu services docker)
#:use-module (gnu services desktop)
+ #:use-module (gnu packages bootstrap)
#:use-module (gnu packages docker)
+ #:use-module (guix derivations)
#:use-module (guix gexp)
+ #:use-module (guix grafts)
+ #:use-module (guix monads)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module (guix scripts pack)
#:use-module (guix store)
+ #:use-module (guix tests)
+ #:use-module (srfi srfi-64)
+ #:use-module (guix build-system trivial)
#:export (%test-docker))
+;; Globally disable grafts because they can trigger early builds.
+;(%graft? #f)
+
(define %docker-os
(simple-operating-system
(service dhcp-client-service-type)
@@ -39,8 +52,9 @@
(service elogind-service-type)
(service docker-service-type)))
-(define (run-docker-test)
- "Run tests in %DOCKER-OS."
+(define (run-docker-test docker-tarball)
+ "Load the DOCKER-TARBALL as docker image and run it in a Docker container,
+inside %DOCKER-OS."
(define os
(marionette-operating-system
%docker-os
@@ -50,8 +64,8 @@
(define vm
(virtual-machine
(operating-system os)
- (memory-size 500)
- (disk-image-size (* 250 (expt 2 20)))
+ (memory-size 1500)
+ (disk-image-size (* 1500 (expt 2 20)))
(port-forwardings '())))
(define test
@@ -87,13 +101,69 @@
"version"))
marionette))
+ (test-equal "pack guest OS as docker image, load it and run it"
+ "hello world"
+ (marionette-eval
+ `(begin
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (read-line port))
+ (status (close-pipe port)))
+ output)))
+ (let* ((raw-text (slurp ,(string-append #$docker-cli
+ "/bin/docker")
+ "load" "-i"
+ ,#$docker-tarball))
+ (repository&tag (string-drop raw-text
+ (string-length
+ "Loaded image: ")))
+ (response (slurp
+ ,(string-append #$docker-cli "/bin/docker")
+ "run" "--entrypoint" "bin/Guile"
+ repository&tag
+ "/aa.scm")))
+ response))
+ marionette))
+
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(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 ->
+ (dummy-package "guest-script"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #: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)))))
+ (profile (profile-derivation (packages->manifest
+ (list %bootstrap-guile
+ guest-script-package))
+ #:hooks '()
+ #:locales? #f))
+ (tarball (docker-image "docker-pack" profile
+ #:symlinks '(("/bin/Guile" -> "bin/guile")
+ ("aa.scm" -> "a.scm"))
+ #:localstatedir? #t)))
+ (run-docker-test tarball)))
+
(define %test-docker
(system-test
(name "docker")
- (description "Connect to the running Docker service.")
- (value (run-docker-test))))
+ (description "Test Docker container of Guix.")
+ (value (build-tarball&run-docker-test))))
+
+;; Local Variables:
+;; eval: (put 'test-assertm 'scheme-indent-function 2)
+;; End:
^ permalink raw reply related [flat|nested] 5+ messages in thread
* [bug#34071] [PATCH v3] tests: docker: Run a guest guile inside the docker container.
2019-01-14 14:46 ` [bug#34071] [PATCH v2] " Danny Milosavljevic
@ 2019-01-14 16:32 ` Danny Milosavljevic
2019-01-15 9:30 ` Ludovic Courtès
0 siblings, 1 reply; 5+ messages in thread
From: Danny Milosavljevic @ 2019-01-14 16:32 UTC (permalink / raw)
To: 34071
* gnu/tests/docker.scm (run-docker-test): Add parameters. Load and run
docker container. Check response of guest guile.
(build-tarball&run-docker-test): New procedure.
(%test-docker): Use it.
[description]: Modify.
---
gnu/tests/docker.scm | 80 ++++++++++++++++++++++++++++++++++++++++----
1 file changed, 74 insertions(+), 6 deletions(-)
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 453ed4893..1b22bad12 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -26,11 +26,22 @@
#:use-module (gnu services networking)
#:use-module (gnu services docker)
#:use-module (gnu services desktop)
+ #:use-module (gnu packages bootstrap) ; %bootstrap-guile
#:use-module (gnu packages docker)
#:use-module (guix gexp)
+ #:use-module (guix grafts)
+ #:use-module (guix monads)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module (guix scripts pack)
#:use-module (guix store)
+ #:use-module (guix tests)
+ #:use-module (guix build-system trivial)
#:export (%test-docker))
+;; Globally disable grafts because they can trigger early builds.
+;(%graft? #f)
+
(define %docker-os
(simple-operating-system
(service dhcp-client-service-type)
@@ -39,8 +50,9 @@
(service elogind-service-type)
(service docker-service-type)))
-(define (run-docker-test)
- "Run tests in %DOCKER-OS."
+(define (run-docker-test docker-tarball)
+ "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
+inside %DOCKER-OS."
(define os
(marionette-operating-system
%docker-os
@@ -50,8 +62,8 @@
(define vm
(virtual-machine
(operating-system os)
- (memory-size 500)
- (disk-image-size (* 250 (expt 2 20)))
+ (memory-size 1500)
+ (disk-image-size (* 1500 (expt 2 20)))
(port-forwardings '())))
(define test
@@ -87,13 +99,69 @@
"version"))
marionette))
+ (test-equal "Load docker image and run it"
+ "hello world"
+ (marionette-eval
+ `(begin
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (read-line port))
+ (status (close-pipe port)))
+ output)))
+ (let* ((raw-line (slurp ,(string-append #$docker-cli
+ "/bin/docker")
+ "load" "-i"
+ ,#$docker-tarball))
+ (repository&tag (string-drop raw-line
+ (string-length
+ "Loaded image: ")))
+ (response (slurp
+ ,(string-append #$docker-cli "/bin/docker")
+ "run" "--entrypoint" "bin/Guile"
+ repository&tag
+ "/aa.scm")))
+ response))
+ marionette))
+
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(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 ->
+ (dummy-package "guest-script"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #: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)))))
+ (profile (profile-derivation (packages->manifest
+ (list %bootstrap-guile
+ guest-script-package))
+ #:hooks '()
+ #:locales? #f))
+ (tarball (docker-image "docker-pack" profile
+ #:symlinks '(("/bin/Guile" -> "bin/guile")
+ ("aa.scm" -> "a.scm"))
+ #:localstatedir? #t)))
+ (run-docker-test tarball)))
+
(define %test-docker
(system-test
(name "docker")
- (description "Connect to the running Docker service.")
- (value (run-docker-test))))
+ (description "Test Docker container of Guix.")
+ (value (build-tarball&run-docker-test))))
+
+;; Local Variables:
+;; eval: (put 'test-assertm 'scheme-indent-function 2)
+;; End:
^ permalink raw reply related [flat|nested] 5+ messages in thread
* [bug#34071] [PATCH v3] tests: docker: Run a guest guile inside the docker container.
2019-01-14 16:32 ` [bug#34071] [PATCH v3] " Danny Milosavljevic
@ 2019-01-15 9:30 ` Ludovic Courtès
2019-01-15 11:47 ` bug#34071: " Danny Milosavljevic
0 siblings, 1 reply; 5+ messages in thread
From: Ludovic Courtès @ 2019-01-15 9:30 UTC (permalink / raw)
To: Danny Milosavljevic; +Cc: 34071
Hi Danny,
Danny Milosavljevic <dannym@scratchpost.org> skribis:
> * gnu/tests/docker.scm (run-docker-test): Add parameters. Load and run
> docker container. Check response of guest guile.
> (build-tarball&run-docker-test): New procedure.
> (%test-docker): Use it.
> [description]: Modify.
This looks great, thank you!
Ludo’.
^ permalink raw reply [flat|nested] 5+ messages in thread
* bug#34071: [PATCH v3] tests: docker: Run a guest guile inside the docker container.
2019-01-15 9:30 ` Ludovic Courtès
@ 2019-01-15 11:47 ` Danny Milosavljevic
0 siblings, 0 replies; 5+ messages in thread
From: Danny Milosavljevic @ 2019-01-15 11:47 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 34071-done
[-- Attachment #1: Type: text/plain, Size: 196 bytes --]
Pushed as 49ec5d88c5770ae49b45849cb691c8921ecf4ca7 with a slight change to
reduce the amount of RAM requested (what is "docker load" doing, loading
the entire image into RAM or what? /mumble).
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 5+ messages in thread
end of thread, other threads:[~2019-01-15 11:48 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2019-01-14 14:35 [bug#34071] [PATCH] tests: docker: Run a guest guile inside the docker container Danny Milosavljevic
2019-01-14 14:46 ` [bug#34071] [PATCH v2] " Danny Milosavljevic
2019-01-14 16:32 ` [bug#34071] [PATCH v3] " Danny Milosavljevic
2019-01-15 9:30 ` Ludovic Courtès
2019-01-15 11:47 ` bug#34071: " Danny Milosavljevic
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).