aboutsummaryrefslogtreecommitdiff
path: root/gnu/tests
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/tests')
-rw-r--r--gnu/tests/dict.scm19
-rw-r--r--gnu/tests/install.scm26
-rw-r--r--gnu/tests/ssh.scm290
-rw-r--r--gnu/tests/web.scm82
4 files changed, 233 insertions, 184 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/install.scm b/gnu/tests/install.scm
index e3bb1b46af..4764ffffde 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -66,8 +66,7 @@
(target "/dev/vdb")))
(kernel-arguments '("console=ttyS0"))
(file-systems (cons (file-system
- (device "my-root")
- (title 'label)
+ (device (file-system-label "my-root"))
(mount-point "/")
(type "ext4"))
%base-file-systems))
@@ -105,8 +104,7 @@
(target "/dev/vdb")))
(kernel-arguments '("console=ttyS0"))
(file-systems (cons (file-system
- (device "my-root")
- (title 'label)
+ (device (file-system-label "my-root"))
(mount-point "/")
(type "ext4"))
%base-file-systems))
@@ -351,8 +349,7 @@ per %test-installed-os, this test is expensive in terms of CPU and storage.")
(target "/dev/vda")))
(kernel-arguments '("console=ttyS0"))
(file-systems (cons (file-system
- (device "my-root")
- (title 'label)
+ (device (file-system-label "my-root"))
(mount-point "/")
(type "ext4"))
%base-file-systems))
@@ -428,13 +425,11 @@ reboot\n")
(target "/dev/vdb")))
(kernel-arguments '("console=ttyS0"))
(file-systems (cons* (file-system
- (device "my-root")
- (title 'label)
+ (device (file-system-label "my-root"))
(mount-point "/")
(type "ext4"))
(file-system
(device "none")
- (title 'device)
(type "tmpfs")
(mount-point "/home")
(type "tmpfs"))
@@ -488,13 +483,11 @@ partition. In particular, home directories must be correctly created (see
(target "/dev/vdb")))
(kernel-arguments '("console=ttyS0"))
(file-systems (cons* (file-system
- (device "root-fs")
- (title 'label)
+ (device (file-system-label "root-fs"))
(mount-point "/")
(type "ext4"))
(file-system
- (device "store-fs")
- (title 'label)
+ (device (file-system-label "store-fs"))
(mount-point "/gnu")
(type "ext4"))
%base-file-systems))
@@ -574,8 +567,7 @@ where /gnu lives on a separate partition.")
(target "/dev/md0")
(type raid-device-mapping))))
(file-systems (cons (file-system
- (device "root-fs")
- (title 'label)
+ (device (file-system-label "root-fs"))
(mount-point "/")
(type "ext4")
(dependencies mapped-devices))
@@ -658,7 +650,6 @@ by 'mdadm'.")
(type luks-device-mapping))))
(file-systems (cons (file-system
(device "/dev/mapper/the-root-device")
- (title 'device)
(mount-point "/")
(type "ext4"))
%base-file-systems))
@@ -779,8 +770,7 @@ build (current-guix) and then store a couple of full system images.")
(target "/dev/vdb")))
(kernel-arguments '("console=ttyS0"))
(file-systems (cons (file-system
- (device "my-root")
- (title 'label)
+ (device (file-system-label "my-root"))
(mount-point "/")
(type "btrfs"))
%base-file-systems))
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))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-28 22:09:27 +0000