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