From c11c19bd4d0dc4ec56b949647057dbf00567f2ae Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 29 Sep 2020 21:33:49 +0200
Subject: services: hurd-vm: Add system test.

* gnu/tests/virtualization.scm (%childhurd-os): New variable.
(run-childhurd-test): New procedure.
(%test-childhurd): New variable.
---
 gnu/tests/virtualization.scm | 141 ++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 140 insertions(+), 1 deletion(-)

(limited to 'gnu/tests')

diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm
index fbdec20805..9d381695be 100644
--- a/gnu/tests/virtualization.scm
+++ b/gnu/tests/virtualization.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,9 +27,16 @@
   #: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 store)
-  #:export (%test-libvirt))
+  #:export (%test-libvirt
+            %test-childhurd))
+
+
+;;;
+;;; Libvirt.
+;;;
 
 (define %libvirt-os
   (simple-operating-system
@@ -93,3 +101,134 @@
    (name "libvirt")
    (description "Connect to the running LIBVIRT service.")
    (value (run-libvirt-test))))
+
+
+;;;
+;;; GNU/Hurd virtual machines, aka. childhurds.
+;;;
+
+(define %childhurd-os
+  (simple-operating-system
+   (service dhcp-client-service-type)
+   (service hurd-vm-service-type)))
+
+(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))))
-- 
cgit v1.2.3