diff options
Diffstat (limited to 'gnu/tests')
| -rw-r--r-- | gnu/tests/dict.scm | 19 | ||||
| -rw-r--r-- | gnu/tests/ssh.scm | 290 | ||||
| -rw-r--r-- | gnu/tests/web.scm | 82 |
3 files changed, 225 insertions, 166 deletions
diff --git a/gnu/tests/dict.scm b/gnu/tests/dict.scm index b9c741e3e0..4431e37dc1 100644 --- a/gnu/tests/dict.scm +++ b/gnu/tests/dict.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,22 +96,7 @@ ;; Wait until dicod is actually listening. ;; TODO: Use a PID file instead. (test-assert "connect inside" - (marionette-eval - '(begin - (use-modules (ice-9 rdelim)) - (let ((sock (socket PF_INET SOCK_STREAM 0))) - (let loop ((i 0)) - (pk 'try i) - (catch 'system-error - (lambda () - (connect sock AF_INET INADDR_LOOPBACK 2628)) - (lambda args - (pk 'connection-error args) - (when (< i 20) - (sleep 1) - (loop (+ 1 i)))))) - (read-line sock 'concat))) - marionette)) + (wait-for-tcp-port 2628 marionette)) (test-assert "connect" (let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000))) diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm index 6abc6c2501..9247a43e6d 100644 --- a/gnu/tests/ssh.scm +++ b/gnu/tests/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; @@ -49,156 +49,150 @@ When SFTP? is true, run an SFTP server test." (define test (with-imported-modules '((gnu build marionette)) - #~(begin - (eval-when (expand load eval) - ;; Prepare to use Guile-SSH. - (set! %load-path - (cons (string-append #+guile-ssh "/share/guile/site/" - (effective-version)) - %load-path))) - - (use-modules (gnu build marionette) - (srfi srfi-26) - (srfi srfi-64) - (ice-9 match) - (ssh session) - (ssh auth) - (ssh channel) - (ssh sftp)) - - (define marionette - ;; Enable TCP forwarding of the guest's port 22. - (make-marionette (list #$vm))) - - (define (make-session-for-test) - "Make a session with predefined parameters for a test." - (make-session #:user "root" - #:port 2222 - #:host "localhost" - #:log-verbosity 'protocol)) - - (define (call-with-connected-session proc) - "Call the one-argument procedure PROC with a freshly created and + (with-extensions (list guile-ssh) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-26) + (srfi srfi-64) + (ice-9 match) + (ssh session) + (ssh auth) + (ssh channel) + (ssh sftp)) + + (define marionette + ;; Enable TCP forwarding of the guest's port 22. + (make-marionette (list #$vm))) + + (define (make-session-for-test) + "Make a session with predefined parameters for a test." + (make-session #:user "root" + #:port 2222 + #:host "localhost" + #:log-verbosity 'protocol)) + + (define (call-with-connected-session proc) + "Call the one-argument procedure PROC with a freshly created and connected SSH session object, return the result of the procedure call. The session is disconnected when the PROC is finished." - (let ((session (make-session-for-test))) - (dynamic-wind - (lambda () - (let ((result (connect! session))) - (unless (equal? result 'ok) - (error "Could not connect to a server" - session result)))) - (lambda () (proc session)) - (lambda () (disconnect! session))))) - - (define (call-with-connected-session/auth proc) - "Make an authenticated session. We should be able to connect as + (let ((session (make-session-for-test))) + (dynamic-wind + (lambda () + (let ((result (connect! session))) + (unless (equal? result 'ok) + (error "Could not connect to a server" + session result)))) + (lambda () (proc session)) + (lambda () (disconnect! session))))) + + (define (call-with-connected-session/auth proc) + "Make an authenticated session. We should be able to connect as root with an empty password." - (call-with-connected-session - (lambda (session) - ;; Try the simple authentication methods. Dropbear requires - ;; 'none' when there are no passwords, whereas OpenSSH accepts - ;; 'password' with an empty password. - (let loop ((methods (list (cut userauth-password! <> "") - (cut userauth-none! <>)))) - (match methods - (() - (error "all the authentication methods failed")) - ((auth rest ...) - (match (pk 'auth (auth session)) - ('success - (proc session)) - ('denied - (loop rest))))))))) - - (mkdir #$output) - (chdir #$output) - - (test-begin "ssh-daemon") - - ;; Wait for sshd to be up and running. - (test-eq "service running" - 'running! - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'ssh-daemon) - 'running!) - marionette)) - - ;; Check sshd's PID file. - (test-equal "sshd PID" - (wait-for-file #$pid-file marionette) - (marionette-eval - '(begin - (use-modules (gnu services herd) - (srfi srfi-1)) - - (live-service-running - (find (lambda (live) - (memq 'ssh-daemon - (live-service-provision live))) - (current-services)))) - marionette)) - - ;; Connect to the guest over SSH. Make sure we can run a shell - ;; command there. - (test-equal "shell command" - 'hello - (call-with-connected-session/auth - (lambda (session) - ;; FIXME: 'get-server-public-key' segfaults. - ;; (get-server-public-key session) - (let ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec channel "echo hello > /root/witness") - (and (zero? (channel-get-exit-status channel)) - (wait-for-file "/root/witness" marionette)))))) - - ;; Connect to the guest over SFTP. Make sure we can write and - ;; read a file there. - (unless #$sftp? - (test-skip 1)) - (test-equal "SFTP file writing and reading" - 'hello - (call-with-connected-session/auth - (lambda (session) - (let ((sftp-session (make-sftp-session session)) - (witness "/root/sftp-witness")) - (call-with-remote-output-file sftp-session witness - (cut display "hello" <>)) - (call-with-remote-input-file sftp-session witness - read))))) - - ;; Connect to the guest over SSH. Make sure we can run commands - ;; from the system profile. - (test-equal "run executables from system profile" - #t - (call-with-connected-session/auth - (lambda (session) - (let ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec - channel - (string-append - "mkdir -p /root/.guix-profile/bin && " - "touch /root/.guix-profile/bin/path-witness && " - "chmod 755 /root/.guix-profile/bin/path-witness")) - (zero? (channel-get-exit-status channel)))))) - - ;; Connect to the guest over SSH. Make sure we can run commands - ;; from the user profile. - (test-equal "run executable from user profile" - #t - (call-with-connected-session/auth - (lambda (session) - (let ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec channel "path-witness") - (zero? (channel-get-exit-status channel)))))) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + (call-with-connected-session + (lambda (session) + ;; Try the simple authentication methods. Dropbear requires + ;; 'none' when there are no passwords, whereas OpenSSH accepts + ;; 'password' with an empty password. + (let loop ((methods (list (cut userauth-password! <> "") + (cut userauth-none! <>)))) + (match methods + (() + (error "all the authentication methods failed")) + ((auth rest ...) + (match (pk 'auth (auth session)) + ('success + (proc session)) + ('denied + (loop rest))))))))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "ssh-daemon") + + ;; Wait for sshd to be up and running. + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'ssh-daemon) + 'running!) + marionette)) + + ;; Check sshd's PID file. + (test-equal "sshd PID" + (wait-for-file #$pid-file marionette) + (marionette-eval + '(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + (live-service-running + (find (lambda (live) + (memq 'ssh-daemon + (live-service-provision live))) + (current-services)))) + marionette)) + + ;; Connect to the guest over SSH. Make sure we can run a shell + ;; command there. + (test-equal "shell command" + 'hello + (call-with-connected-session/auth + (lambda (session) + ;; FIXME: 'get-server-public-key' segfaults. + ;; (get-server-public-key session) + (let ((channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec channel "echo hello > /root/witness") + (and (zero? (channel-get-exit-status channel)) + (wait-for-file "/root/witness" marionette)))))) + + ;; Connect to the guest over SFTP. Make sure we can write and + ;; read a file there. + (unless #$sftp? + (test-skip 1)) + (test-equal "SFTP file writing and reading" + 'hello + (call-with-connected-session/auth + (lambda (session) + (let ((sftp-session (make-sftp-session session)) + (witness "/root/sftp-witness")) + (call-with-remote-output-file sftp-session witness + (cut display "hello" <>)) + (call-with-remote-input-file sftp-session witness + read))))) + + ;; Connect to the guest over SSH. Make sure we can run commands + ;; from the system profile. + (test-equal "run executables from system profile" + #t + (call-with-connected-session/auth + (lambda (session) + (let ((channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec + channel + (string-append + "mkdir -p /root/.guix-profile/bin && " + "touch /root/.guix-profile/bin/path-witness && " + "chmod 755 /root/.guix-profile/bin/path-witness")) + (zero? (channel-get-exit-status channel)))))) + + ;; Connect to the guest over SSH. Make sure we can run commands + ;; from the user profile. + (test-equal "run executable from user profile" + #t + (call-with-connected-session/auth + (lambda (session) + (let ((channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec channel "path-witness") + (zero? (channel-get-exit-status channel)))))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0)))))) (gexp->derivation name test)) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 1912f8f79d..a6bf6efcfe 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> +;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +32,8 @@ #:use-module (guix store) #:export (%test-httpd %test-nginx - %test-php-fpm)) + %test-php-fpm + %test-hpcguix-web)) (define %index.html-contents ;; Contents of the /index.html file. @@ -281,3 +283,81 @@ HTTP-PORT, along with php-fpm." (name "php-fpm") (description "Test PHP-FPM through nginx.") (value (run-php-fpm-test)))) + + +;;; +;;; hpcguix-web +;;; + +(define* (run-hpcguix-web-server-test name test-os) + "Run tests in %HPCGUIX-WEB-OS, which has hpcguix-web running." + (define os + (marionette-operating-system + test-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings '((8080 . 5000))))) + + (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 #$name) + + (test-assert "hpcguix-web running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'hpcguix-web) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((pid) (number? pid)))))) + marionette)) + + (test-equal "http-get" + 200 + (begin + (wait-for-tcp-port 5000 marionette) + (let-values (((response text) + (http-get "http://localhost:8080"))) + (response-code response)))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation (string-append name "-test") test)) + +(define %hpcguix-web-specs + ;; Server config gexp. + #~(define site-config + (hpcweb-configuration + (title-prefix "[TEST] HPCGUIX-WEB")))) + +(define %hpcguix-web-os + (simple-operating-system + (dhcp-client-service) + (service hpcguix-web-service-type + (hpcguix-web-configuration + (specs %hpcguix-web-specs))))) + +(define %test-hpcguix-web + (system-test + (name "hpcguix-web") + (description "Connect to a running hpcguix-web server.") + (value (run-hpcguix-web-server-test name %hpcguix-web-os)))) |