me
/
guix
Archived
1
0
Fork 0
Code

tests: Use 'virtual-machine' records instead of monadic procedures. 

* gnu/tests/base.scm (%test-basic-os): Use 'let*' instead of 'mlet*' and
'virtual-machine' instead of 'system-qemu-image/shared-store-script'.
(run-mcron-test): Likewise.
(run-nss-mdns-test): Likewise.
* gnu/tests/dict.scm (run-dicod-test): Likewise.
* gnu/tests/mail.scm (run-opensmtpd-test): Likewise.
(run-exim-test): Likewise.
* gnu/tests/messaging.scm (run-xmpp-test): Likewise.
* gnu/tests/networking.scm (run-inetd-test): Likewise.
* gnu/tests/nfs.scm (run-nfs-test): Likewise.
* gnu/tests/ssh.scm (run-ssh-test): Likewise.
* gnu/tests/web.scm (run-nginx-test): Likewise.
master
Ludovic Courtès 2017-07-18 10:41:51 +02:00
parent ed419fa0c5
commit 8b113790fa
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
8 changed files with 744 additions and 741 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
gnu/tests/base.scm
View File

@ -34,7 +34,6 @@
#:use-module (gnu packages package-management) #:use-module (gnu packages package-management)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:export (run-basic-test #:export (run-basic-test
@ -393,17 +392,16 @@ info --version")
"Instrument %SIMPLE-OS, run it in a VM, and run a series of basic "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
functionality tests.") functionality tests.")
(value (value
(mlet* %store-monad ((os -> (marionette-operating-system (let* ((os (marionette-operating-system
%simple-os %simple-os
#:imported-modules '((gnu services herd) #:imported-modules '((gnu services herd)
(guix combinators)))) (guix combinators))))
(run (system-qemu-image/shared-store-script (vm (virtual-machine os)))
os #:graphic? #f)))
;; XXX: Add call to 'virtualized-operating-system' to get the exact same ;; XXX: Add call to 'virtualized-operating-system' to get the exact same
;; set of services as the OS produced by ;; set of services as the OS produced by
;; 'system-qemu-image/shared-store-script'. ;; 'system-qemu-image/shared-store-script'.
(run-basic-test (virtualized-operating-system os '()) (run-basic-test (virtualized-operating-system os '())
#~(list #$run)))))) #~(list #$vm))))))
;;; ;;;
@ -430,12 +428,12 @@ functionality tests.")
(mcron-service (list job1 job2 job3))))) (mcron-service (list job1 job2 job3)))))
(define (run-mcron-test name) (define (run-mcron-test name)
(mlet* %store-monad ((os -> (marionette-operating-system (define os
(marionette-operating-system
%mcron-os %mcron-os
#:imported-modules '((gnu services herd) #:imported-modules '((gnu services herd)
(guix combinators)))) (guix combinators))))
(command (system-qemu-image/shared-store-script
os #:graphic? #f)))
(define test (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
@ -444,7 +442,7 @@ functionality tests.")
(ice-9 match)) (ice-9 match))
(define marionette (define marionette
(make-marionette (list #$command))) (make-marionette (list #$(virtual-machine os))))
(mkdir #$output) (mkdir #$output)
(chdir #$output) (chdir #$output)
@ -483,7 +481,7 @@ functionality tests.")
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation name test))) (gexp->derivation name test))
(define %test-mcron (define %test-mcron
(system-test (system-test
@ -526,13 +524,13 @@ functionality tests.")
;; *after* nscd. Failing to do that, libc will try to connect to nscd, ;; *after* nscd. Failing to do that, libc will try to connect to nscd,
;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc), ;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc),
;; leading to '.local' resolution failures. ;; leading to '.local' resolution failures.
(mlet* %store-monad ((os -> (marionette-operating-system (define os
(marionette-operating-system
%avahi-os %avahi-os
#:requirements '(nscd) #:requirements '(nscd)
#:imported-modules '((gnu services herd) #:imported-modules '((gnu services herd)
(guix combinators)))) (guix combinators))))
(run (system-qemu-image/shared-store-script
os #:graphic? #f)))
(define mdns-host-name (define mdns-host-name
(string-append (operating-system-host-name os) (string-append (operating-system-host-name os)
".local")) ".local"))
@ -546,7 +544,7 @@ functionality tests.")
(ice-9 match)) (ice-9 match))
(define marionette (define marionette
(make-marionette (list #$run))) (make-marionette (list #$(virtual-machine os))))
(mkdir #$output) (mkdir #$output)
(chdir #$output) (chdir #$output)
@ -621,7 +619,7 @@ functionality tests.")
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation "nss-mdns" test))) (gexp->derivation "nss-mdns" test))
(define %test-nss-mdns (define %test-nss-mdns
(system-test (system-test

17
gnu/tests/dict.scm
View File

@ -27,7 +27,6 @@
#:use-module (gnu packages wordnet) #:use-module (gnu packages wordnet)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix modules) #:use-module (guix modules)
#:export (%test-dicod)) #:export (%test-dicod))
@ -54,12 +53,17 @@
(define* (run-dicod-test) (define* (run-dicod-test)
"Run tests of 'dicod-service-type'." "Run tests of 'dicod-service-type'."
(mlet* %store-monad ((os -> (marionette-operating-system (define os
(marionette-operating-system
%dicod-os %dicod-os
#:imported-modules #:imported-modules
(source-module-closure '((gnu services herd))))) (source-module-closure '((gnu services herd)))))
(command (system-qemu-image/shared-store-script
os #:graphic? #f))) (define vm
(virtual-machine
(operating-system os)
(port-forwardings '((8000 . 2628)))))
(define test (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
@ -69,8 +73,7 @@
(gnu build marionette)) (gnu build marionette))
(define marionette (define marionette
;; Forward the guest's DICT port to local port 8000. ;; Forward the guest's DICT port to local port 8000.
(make-marionette (list #$command "-net" (make-marionette (list #$vm)))
"user,hostfwd=tcp::8000-:2628")))
(define %dico-socket (define %dico-socket
(socket PF_INET SOCK_STREAM 0)) (socket PF_INET SOCK_STREAM 0))
@ -133,7 +136,7 @@
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation "dicod" test))) (gexp->derivation "dicod" test))
(define %test-dicod (define %test-dicod
(system-test (system-test

34
gnu/tests/mail.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org> ;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au> ;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au>
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -25,7 +26,6 @@
#:use-module (gnu services mail) #:use-module (gnu services mail)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix store) #:use-module (guix store)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:export (%test-opensmtpd #:export (%test-opensmtpd
@ -44,11 +44,13 @@ accept from any for local deliver to mbox
(define (run-opensmtpd-test) (define (run-opensmtpd-test)
"Return a test of an OS running OpenSMTPD service." "Return a test of an OS running OpenSMTPD service."
(mlet* %store-monad ((command (system-qemu-image/shared-store-script (define vm
(marionette-operating-system (virtual-machine
(operating-system (marionette-operating-system
%opensmtpd-os %opensmtpd-os
#:imported-modules '((gnu services herd))) #:imported-modules '((gnu services herd))))
#:graphic? #f))) (port-forwardings '((1025 . 25)))))
(define test (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
@ -59,9 +61,7 @@ accept from any for local deliver to mbox
(gnu build marionette)) (gnu build marionette))
(define marionette (define marionette
(make-marionette (make-marionette '(#$vm)))
;; Enable TCP forwarding of the guest's port 25.
'(#$command "-net" "user,hostfwd=tcp::1025-:25")))
(define (read-reply-code port) (define (read-reply-code port)
"Read a SMTP reply from PORT and return its reply code." "Read a SMTP reply from PORT and return its reply code."
@ -142,7 +142,7 @@ accept from any for local deliver to mbox
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation "opensmtpd-test" test))) (gexp->derivation "opensmtpd-test" test))
(define %test-opensmtpd (define %test-opensmtpd
(system-test (system-test
@ -179,11 +179,13 @@ acl_check_data:
(define (run-exim-test) (define (run-exim-test)
"Return a test of an OS running an Exim service." "Return a test of an OS running an Exim service."
(mlet* %store-monad ((command (system-qemu-image/shared-store-script (define vm
(marionette-operating-system (virtual-machine
(operating-system (marionette-operating-system
%exim-os %exim-os
#:imported-modules '((gnu services herd))) #:imported-modules '((gnu services herd))))
#:graphic? #f))) (port-forwardings '((1025 . 25)))))
(define test (define test
(with-imported-modules '((gnu build marionette) (with-imported-modules '((gnu build marionette)
(ice-9 ftw)) (ice-9 ftw))
@ -196,9 +198,7 @@ acl_check_data:
(gnu build marionette)) (gnu build marionette))
(define marionette (define marionette
(make-marionette (make-marionette '(#$vm)))
;; Enable TCP forwarding of the guest's port 25.
'(#$command "-net" "user,hostfwd=tcp::1025-:25")))
(define (read-reply-code port) (define (read-reply-code port)
"Read a SMTP reply from PORT and return its reply code." "Read a SMTP reply from PORT and return its reply code."
@ -272,7 +272,7 @@ acl_check_data:
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation "exim-test" test))) (gexp->derivation "exim-test" test))
(define %test-exim (define %test-exim
(system-test (system-test

36
gnu/tests/messaging.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -26,24 +27,29 @@
#:use-module (gnu packages messaging) #:use-module (gnu packages messaging)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads)
#:export (%test-prosody)) #:export (%test-prosody))
(define (run-xmpp-test name xmpp-service pid-file create-account) (define (run-xmpp-test name xmpp-service pid-file create-account)
"Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE." "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE."
(mlet* %store-monad ((os -> (marionette-operating-system (define os
(marionette-operating-system
(simple-operating-system (dhcp-client-service) (simple-operating-system (dhcp-client-service)
xmpp-service) xmpp-service)
#:imported-modules '((gnu services herd)))) #:imported-modules '((gnu services herd))))
(command (system-qemu-image/shared-store-script
os #:graphic? #f)) (define port 15222)
(username -> "alice")
(server -> "localhost") (define vm
(jid -> (string-append username "@" server)) (virtual-machine
(password -> "correct horse battery staple") (operating-system os)
(port -> 15222) (port-forwardings `((,port . 5222)))))
(message -> "hello world")
(witness -> "/tmp/freetalk-witness")) (define username "alice")
(define server "localhost")
(define jid (string-append username "@" server))
(define password "correct horse battery staple")
(define message "hello world")
(define witness "/tmp/freetalk-witness")
(define script.ft (define script.ft
(scheme-file (scheme-file
@ -74,11 +80,7 @@
(srfi srfi-64)) (srfi srfi-64))
(define marionette (define marionette
;; Enable TCP forwarding of the guest's port 5222. (make-marionette (list #$vm)))
(make-marionette (list #$command "-net"
(string-append "user,hostfwd=tcp::"
(number->string #$port)
"-:5222"))))
(define (host-wait-for-file file) (define (host-wait-for-file file)
;; Wait until FILE exists in the host. ;; Wait until FILE exists in the host.
@ -127,7 +129,7 @@
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation name test))) (gexp->derivation name test))
(define %create-prosody-account (define %create-prosody-account
(program-file (program-file

21
gnu/tests/networking.scm
View File

@ -74,9 +74,15 @@ done" ))))))))))
(define* (run-inetd-test) (define* (run-inetd-test)
"Run tests in %INETD-OS, where the inetd service provides an echo service on "Run tests in %INETD-OS, where the inetd service provides an echo service on
port 7, and a dict service on port 2628." port 7, and a dict service on port 2628."
(mlet* %store-monad ((os -> (marionette-operating-system %inetd-os)) (define os
(command (system-qemu-image/shared-store-script (marionette-operating-system %inetd-os))
os #:graphic? #f)))
(define vm
(virtual-machine
(operating-system os)
(port-forwardings `((8007 . 7)
(8628 . 2628)))))
(define test (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
@ -84,12 +90,7 @@ port 7, and a dict service on port 2628."
(srfi srfi-64) (srfi srfi-64)
(gnu build marionette)) (gnu build marionette))
(define marionette (define marionette
;; Forward guest ports 7 and 2628 to host ports 8007 and 8628. (make-marionette (list #$vm)))
(make-marionette (list #$command "-net"
(string-append
"user"
",hostfwd=tcp::8007-:7"
",hostfwd=tcp::8628-:2628"))))
(mkdir #$output) (mkdir #$output)
(chdir #$output) (chdir #$output)
@ -127,7 +128,7 @@ port 7, and a dict service on port 2628."
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation "inetd-test" test))) (gexp->derivation "inetd-test" test))
(define %test-inetd (define %test-inetd
(system-test (system-test

12
gnu/tests/nfs.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 John Darrington <jmd@gnu.org> ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
@ -55,12 +55,12 @@
(define (run-nfs-test name socket) (define (run-nfs-test name socket)
"Run a test of an OS running RPC-SERVICE, which should create SOCKET." "Run a test of an OS running RPC-SERVICE, which should create SOCKET."
(mlet* %store-monad ((os -> (marionette-operating-system (define os
(marionette-operating-system
%base-os %base-os
#:imported-modules '((gnu services herd) #:imported-modules '((gnu services herd)
(guix combinators)))) (guix combinators))))
(command (system-qemu-image/shared-store-script
os #:graphic? #f)))
(define test (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
@ -68,7 +68,7 @@
(srfi srfi-64)) (srfi srfi-64))
(define marionette (define marionette
(make-marionette (list #$command))) (make-marionette (list #$(virtual-machine os))))
(define (wait-for-socket file) (define (wait-for-socket file)
;; Wait until SOCKET exists in the guest ;; Wait until SOCKET exists in the guest
@ -123,7 +123,7 @@
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation name test))) (gexp->derivation name test))
(define %test-nfs (define %test-nfs
(system-test (system-test

20
gnu/tests/ssh.scm
View File

@ -27,7 +27,6 @@
#:use-module (gnu packages ssh) #:use-module (gnu packages ssh)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads)
#:export (%test-openssh #:export (%test-openssh
%test-dropbear)) %test-dropbear))
@ -37,14 +36,16 @@ SSH-SERVICE must be configured to listen on port 22 and to allow for root and
empty-password logins. empty-password logins.
When SFTP? is true, run an SFTP server test." When SFTP? is true, run an SFTP server test."
(mlet* %store-monad ((os -> (marionette-operating-system (define os
(simple-operating-system (marionette-operating-system
(dhcp-client-service) (simple-operating-system (dhcp-client-service) ssh-service)
ssh-service)
#:imported-modules '((gnu services herd) #:imported-modules '((gnu services herd)
(guix combinators)))) (guix combinators))))
(command (system-qemu-image/shared-store-script (define vm
os #:graphic? #f))) (virtual-machine
(operating-system os)
(port-forwardings '((2222 . 22)))))
(define test (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
@ -66,8 +67,7 @@ When SFTP? is true, run an SFTP server test."
(define marionette (define marionette
;; Enable TCP forwarding of the guest's port 22. ;; Enable TCP forwarding of the guest's port 22.
(make-marionette (list #$command "-net" (make-marionette (list #$vm)))
"user,hostfwd=tcp::2222-:22")))
(define (make-session-for-test) (define (make-session-for-test)
"Make a session with predefined parameters for a test." "Make a session with predefined parameters for a test."
@ -172,7 +172,7 @@ root with an empty password."
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation name test))) (gexp->derivation name test))
(define %test-openssh (define %test-openssh
(system-test (system-test

21
gnu/tests/web.scm
View File

@ -27,7 +27,6 @@
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads)
#:export (%test-nginx)) #:export (%test-nginx))
(define %index.html-contents (define %index.html-contents
@ -65,12 +64,17 @@
(define* (run-nginx-test #:optional (http-port 8042)) (define* (run-nginx-test #:optional (http-port 8042))
"Run tests in %NGINX-OS, which has nginx running and listening on "Run tests in %NGINX-OS, which has nginx running and listening on
HTTP-PORT." HTTP-PORT."
(mlet* %store-monad ((os -> (marionette-operating-system (define os
(marionette-operating-system
%nginx-os %nginx-os
#:imported-modules '((gnu services herd) #:imported-modules '((gnu services herd)
(guix combinators)))) (guix combinators))))
(command (system-qemu-image/shared-store-script
os #:graphic? #f))) (define vm
(virtual-machine
(operating-system os)
(port-forwardings `((8080 . ,http-port)))))
(define test (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
@ -81,12 +85,7 @@ HTTP-PORT."
(web response)) (web response))
(define marionette (define marionette
;; Forward the guest's HTTP-PORT, where nginx is listening, to (make-marionette (list #$vm)))
;; port 8080 in the host.
(make-marionette (list #$command "-net"
(string-append
"user,hostfwd=tcp::8080-:"
#$(number->string http-port)))))
(mkdir #$output) (mkdir #$output)
(chdir #$output) (chdir #$output)
@ -126,7 +125,7 @@ HTTP-PORT."
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation "nginx-test" test))) (gexp->derivation "nginx-test" test))
(define %test-nginx (define %test-nginx
(system-test (system-test