diff options
Diffstat (limited to 'gnu/tests')
| -rw-r--r-- | gnu/tests/guix.scm | 75 | ||||
| -rw-r--r-- | gnu/tests/install.scm | 51 | ||||
| -rw-r--r-- | gnu/tests/virtualization.scm | 160 |
3 files changed, 259 insertions, 27 deletions
diff --git a/gnu/tests/guix.scm b/gnu/tests/guix.scm index 6139e31cf0..20b67d55d3 100644 --- a/gnu/tests/guix.scm +++ b/gnu/tests/guix.scm @@ -35,7 +35,80 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (ice-9 match) - #:export (%test-guix-data-service)) + #:export (%test-guix-build-coordinator + %test-guix-data-service)) + +;;; +;;; Guix Build Coordinator +;;; + +(define %guix-build-coordinator-os + (simple-operating-system + (service dhcp-client-service-type) + (service guix-build-coordinator-service-type))) + +(define (run-guix-build-coordinator-test) + (define os + (marionette-operating-system + %guix-build-coordinator-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define forwarded-port 8745) + + (define vm + (virtual-machine + (operating-system os) + (memory-size 1024) + (port-forwardings `((,forwarded-port . 8745))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette) + (web uri) + (web client) + (web response)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "guix-build-coordinator") + + (test-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'guix-build-coordinator) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((pid) (number? pid)))))) + marionette)) + + (test-equal "http-get" + 200 + (let-values + (((response text) + (http-get #$(simple-format + #f "http://localhost:~A/metrics" forwarded-port) + #:decode-body? #t))) + (response-code response))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "guix-build-coordinator-test" test)) + +(define %test-guix-build-coordinator + (system-test + (name "guix-build-coordinator") + (description "Connect to a running Guix Build Coordinator.") + (value (run-guix-build-coordinator-test)))) ;;; diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 5b7f9bf671..86bd93966b 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -35,6 +35,8 @@ #:use-module (gnu packages bootloaders) #:use-module (gnu packages commencement) ;for 'guile-final' #:use-module (gnu packages cryptsetup) + #:use-module (gnu packages emacs) + #:use-module (gnu packages emacs-xyz) #:use-module (gnu packages linux) #:use-module (gnu packages ocr) #:use-module (gnu packages openbox) @@ -218,7 +220,7 @@ reboot\n") #:imported-modules '((gnu services herd) (gnu installer tests) (guix combinators)))) - (installation-disk-image-file-system-type "ext4") + (installation-image-type 'raw) (install-size 'guess) (target-size (* 2200 MiB))) "Run SCRIPT (a shell script following the system installation procedure) in @@ -228,10 +230,6 @@ packages defined in installation-os." (mlet* %store-monad ((_ (set-grafting #f)) (system (current-system)) - (target (current-target-system)) - (base-image -> (find-image - installation-disk-image-file-system-type - target)) ;; Since the installation system has no network access, ;; we cheat a little bit by adding TARGET to its GC @@ -239,18 +237,20 @@ packages defined in installation-os." ;; succeed. Also add guile-final, which is pulled in ;; through provenance.drv and may not always be present. (target (operating-system-derivation target-os)) + (base-image -> + (os->image + (operating-system-with-gc-roots + os (list target guile-final)) + #:type (lookup-image-type-by-name + installation-image-type))) (image -> - (system-image - (image - (inherit base-image) - (size install-size) - (operating-system - (operating-system-with-gc-roots - os (list target guile-final))) - ;; Do not compress to speed-up the tests. - (compression? #f) - ;; Don't provide substitutes; too big. - (substitutable? #f))))) + (system-image + (image + (inherit base-image) + (size install-size) + + ;; Don't provide substitutes; too big. + (substitutable? #f))))) (define install (with-imported-modules '((guix build utils) (gnu build marionette)) @@ -270,16 +270,16 @@ packages defined in installation-os." "-no-reboot" "-m" "1200" #$@(cond - ((string=? "ext4" installation-disk-image-file-system-type) + ((eq? 'raw installation-image-type) #~("-drive" ,(string-append "file=" #$image ",if=virtio,readonly"))) - ((string=? "iso9660" installation-disk-image-file-system-type) + ((eq? 'uncompressed-iso9660 installation-image-type) #~("-cdrom" #$image)) (else (error - "unsupported installation-disk-image-file-system-type:" - installation-disk-image-file-system-type))) + "unsupported installation-image-type:" + installation-image-type))) "-drive" ,(string-append "file=" #$output ",if=virtio") ,@(if (file-exists? "/dev/kvm") @@ -443,8 +443,8 @@ reboot\n") %minimal-os-on-vda-source #:script %simple-installation-script-for-/dev/vda - #:installation-disk-image-file-system-type - "iso9660")) + #:installation-image-type + 'uncompressed-iso9660)) (command (qemu-command/writable-image image))) (run-basic-test %minimal-os-on-vda command name))))) @@ -1273,7 +1273,8 @@ build (current-guix) and then store a couple of full system images.") ;; graphical installer are available. (packages (append (list openbox awesome i3-wm i3status - dmenu st ratpoison xterm) + dmenu st ratpoison xterm + emacs emacs-exwm emacs-desktop-environment) %base-packages)) (services (append @@ -1309,8 +1310,8 @@ build (current-guix) and then store a couple of full system images.") #:os installation-os-for-gui-tests #:install-size install-size #:target-size target-size - #:installation-disk-image-file-system-type - "iso9660" + #:installation-image-type + 'uncompressed-iso9660 #:gui-test (lambda (marionette) (gui-test-program diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm index fbdec20805..e95787ee19 100644 --- a/gnu/tests/virtualization.scm +++ b/gnu/tests/virtualization.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,17 +20,28 @@ (define-module (gnu tests virtualization) #:use-module (gnu tests) + #:use-module (gnu image) #:use-module (gnu system) #:use-module (gnu system file-systems) + #:use-module (gnu system image) + #:use-module (gnu system images hurd) #:use-module (gnu system vm) #:use-module (gnu services) #:use-module (gnu services dbus) #:use-module (gnu services networking) #:use-module (gnu services virtualization) #:use-module (gnu packages virtualization) + #:use-module (gnu packages ssh) #:use-module (guix gexp) + #:use-module (guix records) #:use-module (guix store) - #:export (%test-libvirt)) + #:export (%test-libvirt + %test-childhurd)) + + +;;; +;;; Libvirt. +;;; (define %libvirt-os (simple-operating-system @@ -93,3 +106,148 @@ (name "libvirt") (description "Connect to the running LIBVIRT service.") (value (run-libvirt-test)))) + + +;;; +;;; GNU/Hurd virtual machines, aka. childhurds. +;;; + +;; Copy of `hurd-vm-disk-image', using plain disk-image for test +(define (hurd-vm-disk-image-raw config) + (let ((os ((@@ (gnu services virtualization) secret-service-operating-system) + (hurd-vm-configuration-os config))) + (disk-size (hurd-vm-configuration-disk-size config))) + (system-image + (image + (inherit hurd-disk-image) + (format 'disk-image) + (size disk-size) + (operating-system os))))) + +(define %childhurd-os + (simple-operating-system + (service dhcp-client-service-type) + (service hurd-vm-service-type + (hurd-vm-configuration + (image (hurd-vm-disk-image-raw this-record)))))) + +(define (run-childhurd-test) + (define os + (marionette-operating-system + %childhurd-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (memory-size (* 1024 3)))) + + (define run-uname-over-ssh + ;; Program that runs 'uname' over SSH and prints the result on standard + ;; output. + (let () + (define run + (with-extensions (list guile-ssh) + #~(begin + (use-modules (ssh session) + (ssh auth) + (ssh popen) + (ice-9 match) + (ice-9 textual-ports)) + + (let ((session (make-session #:user "root" + #:port 10022 + #:host "localhost" + #:log-verbosity 'rare))) + (match (connect! session) + ('ok + (userauth-password! session "") + (display + (get-string-all + (open-remote-input-pipe* session "uname" "-on")))) + (status + (error "could not connect to childhurd over SSH" + session status))))))) + + (program-file "run-uname-over-ssh" run))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "childhurd") + + (test-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'childhurd) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((pid) (number? pid)))))) + marionette)) + + (test-equal "childhurd SSH server replies" + "SSH" + ;; Check from within the guest whether its childhurd's SSH + ;; server is reachable. Do that from the guest: port forwarding + ;; to the host won't work because QEMU listens on 127.0.0.1. + (marionette-eval + '(begin + (use-modules (ice-9 match)) + + (let loop ((n 60)) + (if (zero? n) + 'all-attempts-failed + (let ((s (socket PF_INET SOCK_STREAM 0)) + (a (make-socket-address AF_INET + INADDR_LOOPBACK + 10022))) + (format #t "connecting to childhurd SSH server...~%") + (connect s a) + (match (get-string-n s 3) + ((? eof-object?) + (close-port s) + (sleep 1) + (loop (- n 1))) + (str + (close-port s) + str)))))) + marionette)) + + (test-equal "SSH up and running" + "childhurd GNU\n" + + ;; Connect from the guest to the chidhurd over SSH and run the + ;; 'uname' command. + (marionette-eval + '(begin + (use-modules (ice-9 popen)) + + (get-string-all + (open-input-pipe #$run-uname-over-ssh))) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "childhurd-test" test)) + +(define %test-childhurd + (system-test + (name "childhurd") + (description + "Connect to the GNU/Hurd virtual machine service, aka. a childhurd, making +sure that the childhurd boots and runs its SSH server.") + (value (run-childhurd-test)))) |