diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/system/vm.scm | 18 | ||||
| -rw-r--r-- | gnu/tests/docker.scm | 118 |
2 files changed, 133 insertions, 3 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2eeb700793..aa37896498 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -482,7 +482,7 @@ system." (define* (system-docker-image os #:key - (name "guixsd-docker-image") + (name "guix-docker-image") (register-closures? (has-guix-service-type? os))) "Build a docker image. OS is the desired <operating-system>. NAME is the base name to use for the output file. When REGISTER-CLOSURES? is true, @@ -495,7 +495,19 @@ system." (local-file (search-path %load-path "guix/store/schema.sql")))) - (let ((os (containerized-operating-system os '())) + (define boot-program + ;; Program that runs the boot script of OS, which in turn starts shepherd. + (program-file "boot-program" + #~(let ((system (cadr (command-line)))) + (setenv "GUIX_NEW_SYSTEM" system) + (execl #$(file-append guile-2.2 "/bin/guile") + "guile" "--no-auto-compile" + (string-append system "/boot"))))) + + + (let ((os (operating-system-with-gc-roots + (containerized-operating-system os '()) + (list boot-program))) (name (string-append name ".tar.gz")) (graph "system-graph")) (define build @@ -546,9 +558,11 @@ system." (string-append "/xchg/" #$graph) read-reference-graph))) #$os + #:entry-point '(#$boot-program #$os) #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:creation-time (make-time time-utc 0 1) #:transformations `((,root-directory -> "")))))))) + (expression->derivation-in-linux-vm name build #:make-disk-image? #f diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 25e172efae..3cd3a27884 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,7 @@ #:use-module (gnu services desktop) #:use-module (gnu packages bootstrap) ; %bootstrap-guile #:use-module (gnu packages docker) + #:use-module (gnu packages guile) #:use-module (guix gexp) #:use-module (guix grafts) #:use-module (guix monads) @@ -38,7 +40,8 @@ #:use-module (guix tests) #:use-module (guix build-system trivial) #:use-module ((guix licenses) #:prefix license:) - #:export (%test-docker)) + #:export (%test-docker + %test-docker-system)) (define %docker-os (simple-operating-system @@ -166,3 +169,116 @@ standard output device and then enters a new line.") (name "docker") (description "Test Docker container of Guix.") (value (build-tarball&run-docker-test)))) + + +(define (run-docker-system-test tarball) + "Load DOCKER-TARBALL as Docker image and run it in a Docker container, +inside %DOCKER-OS." + (define os + (marionette-operating-system + %docker-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + ;; FIXME: Because we're using the volatile-root setup where the root file + ;; system is a tmpfs overlaid over a small root file system, 'docker + ;; load' must be able to store the whole image into memory, hence the + ;; huge memory requirements. We should avoid the volatile-root setup + ;; instead. + (memory-size 3000) + (port-forwardings '()))) + + (define test + (with-imported-modules '((gnu build marionette) + (guix build utils)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette) + (guix build utils)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "docker") + + (test-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'dockerd) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((pid) (number? pid)))))) + marionette)) + + (test-assert "load system image and run it" + (marionette-eval + `(begin + (define (slurp command . args) + ;; Return the output from COMMAND. + (let* ((port (apply open-pipe* OPEN_READ command args)) + (output (read-line port)) + (status (close-pipe port))) + output)) + + (define (docker-cli command . args) + ;; Run the given Docker COMMAND. + (apply invoke #$(file-append docker-cli "/bin/docker") + command args)) + + (define (wait-for-container-file container file) + ;; Wait for FILE to show up in CONTAINER. + (docker-cli "exec" container + #$(file-append guile-2.2 "/bin/guile") + "-c" + (object->string + `(let loop ((n 15)) + (when (zero? n) + (error "file didn't show up" ,file)) + (unless (file-exists? ,file) + (sleep 1) + (loop (- n 1))))))) + + (let* ((line (slurp #$(file-append docker-cli "/bin/docker") + "load" "-i" #$tarball)) + (repository&tag (string-drop line + (string-length + "Loaded image: "))) + (container (slurp + #$(file-append docker-cli "/bin/docker") + "create" repository&tag))) + (docker-cli "start" container) + + ;; Wait for shepherd to be ready. + (wait-for-container-file container + "/var/run/shepherd/socket") + + (docker-cli "exec" container + "/run/current-system/profile/bin/herd" + "status") + (slurp #$(file-append docker-cli "/bin/docker") + "exec" container + "/run/current-system/profile/bin/herd" + "status" "guix-daemon"))) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "docker-system-test" test)) + +(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 + (>>= (system-docker-image (simple-operating-system)) + run-docker-system-test))))) |