GNU bug report logs - #34071
[PATCH] tests: docker: Run a guest guile inside the docker container.

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 34071 in the body.
You can then email your comments to 34071 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Danny Milosavljevic <dannym <at> scratchpost.org>
To: guix-patches <at> gnu.org
Cc: Danny Milosavljevic <dannym <at> scratchpost.org>
Subject: [PATCH] tests: docker: Run a guest guile inside the docker container.
Date: Mon, 14 Jan 2019 15:35:45 +0100

* 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 <at> scratchpost.org>
 ;;; Copyright © 2017 Christopher Baines <mail <at> 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:

Message #8 received at 34071 <at> debbugs.gnu.org (full text, mbox):

From: Danny Milosavljevic <dannym <at> scratchpost.org>
To: 34071 <at> debbugs.gnu.org
Cc: Danny Milosavljevic <dannym <at> scratchpost.org>
Subject: [PATCH v2] tests: docker: Run a guest guile inside the docker
 container.
Date: Mon, 14 Jan 2019 15:46:43 +0100

* 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:

Message #11 received at 34071 <at> debbugs.gnu.org (full text, mbox):

From: Danny Milosavljevic <dannym <at> scratchpost.org>
To: 34071 <at> debbugs.gnu.org
Cc: Danny Milosavljevic <dannym <at> scratchpost.org>
Subject: [PATCH v3] tests: docker: Run a guest guile inside the docker
 container.
Date: Mon, 14 Jan 2019 17:32:24 +0100

* 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:

Message #14 received at 34071 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: Danny Milosavljevic <dannym <at> scratchpost.org>
Cc: 34071 <at> debbugs.gnu.org
Subject: Re: [bug#34071] [PATCH v3] tests: docker: Run a guest guile inside
 the docker container.
Date: Tue, 15 Jan 2019 10:30:04 +0100

Hi Danny,

Danny Milosavljevic <dannym <at> 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’.

Message #19 received at 34071-done <at> debbugs.gnu.org (full text, mbox):

From: Danny Milosavljevic <dannym <at> scratchpost.org>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 34071-done <at> debbugs.gnu.org
Subject: Re: [bug#34071] [PATCH v3] tests: docker: Run a guest guile inside
 the docker container.
Date: Tue, 15 Jan 2019 12:47:15 +0100

[Message part 1 (text/plain, inline)]

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).

[Message part 2 (application/pgp-signature, inline)]

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.