WIPsystem-container-networking-test

2 files changed, 139 insertions, 0 deletions

diff --git a/gnu/tests/container.scm b/gnu/tests/container.scm
new file mode 100644
index 0000000000..4343cf97b2
--- /dev/null
+++ b/gnu/tests/container.scm
@@ -0,0 +1,113 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests container)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu system vm)
+  #:use-module (gnu packages gnupg) ;; For libgcrypt
+  #:use-module (gnu packages package-management)
+  #:use-module (gnu services)
+  #:use-module (gnu services admin)
+  #:use-module (gnu services web)
+  #:use-module (gnu services networking)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:use-module (guix modules)
+  #:use-module (guix monads)
+  #:export (%test-guix-system-container))
+
+(define %os
+  (simple-operating-system
+   (service nginx-service-type
+            (nginx-configuration))))
+
+(define %vm
+  (virtual-machine
+   (operating-system
+     (marionette-operating-system
+      %os
+      #:imported-modules '((gnu services herd)
+                           (guix combinators))))
+   (port-forwardings '())))
+
+(define %test-guix-system-container
+  (system-test
+   (name "guix-system-container")
+   (description "Test a system container created through the guix system
+container command.")
+   (value
+    (gexp->derivation
+     name
+     (with-imported-modules (source-module-closure
+                             '((gnu build marionette)))
+       #~(begin
+           (use-modules (srfi srfi-11) (srfi srfi-64)
+                        (ice-9 match)
+                        (ice-9 rdelim)
+                        (ice-9 popen)
+                        (gnu build marionette))
+
+           (define marionette
+             (make-marionette (list #$%vm)))
+
+           (define libgcrypt #$libgcrypt)
+
+           (mkdir #$output)
+           (chdir #$output)
+
+           (test-begin "guix-system-container")
+
+           (display (environ))
+           (display "\n")
+
+           (marionette-eval
+            '(use-modules (ice-9 popen)
+                          (ice-9 rdelim))
+            marionette)
+
+           (let ((start-script
+                  (marionette-eval
+                   '(let* ((command
+                            '("guix" "system" "container"
+                              #$(local-file "./container/test-system.scm")))
+                           (pipe    (apply open-pipe* OPEN_READ command))
+                           (str     (read-line pipe))
+                           (status  (close-pipe pipe)))
+
+                      (display (environ))
+                      (display "\n")
+
+                      (apply system* command)
+
+                      (simple-format #t "output: ~A\n" str)
+
+                      (if (zero? status)
+                          str
+                          status))
+                   marionette)))
+
+             (simple-format #t "start script: ~A\n" start-script)
+
+             (test-assert "start script created"
+               (string? start-script)))
+
+           (test-end)
+           (exit (= (test-runner-fail-count (test-runner-current)) 0))))))))
diff --git a/gnu/tests/container/test-system.scm b/gnu/tests/container/test-system.scm
new file mode 100644
index 0000000000..03b26a691a
--- /dev/null
+++ b/gnu/tests/container/test-system.scm
@@ -0,0 +1,26 @@
+(define-module (gnu tests container test-system)
+  #:use-module (gnu)
+  #:use-module (gnu packages package-management)
+  #:export (%system))
+
+(define %system
+  (operating-system
+    (host-name "guix-container")
+    (timezone "Europe/Berlin")
+    (locale "en_US.utf8")
+
+    (packages (cons* guix
+                     %base-packages))
+
+    ;; TODO file-systems is redundant
+    (file-systems
+     (cons (file-system
+             (device "my-root")
+             (title 'label)
+             (mount-point "/")
+             (type "ext4"))
+           %base-file-systems))
+
+    (bootloader (grub-configuration (device "/dev/sdX")))))
+
+%system