Commit | Line | Data |
---|---|---|
eda4bb4f CB |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Christopher Baines <mail@cbaines.net> | |
4 | ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> | |
5 | ;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr> | |
6 | ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> | |
7 | ;;; | |
8 | ;;; This file is part of GNU Guix. | |
9 | ;;; | |
10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
11 | ;;; under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
15 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | (define-module (gnu tests ci) | |
24 | #:use-module (gnu tests) | |
25 | #:use-module (gnu system) | |
26 | #:use-module (gnu system file-systems) | |
27 | #:use-module (gnu system shadow) | |
28 | #:use-module (gnu system vm) | |
29 | #:use-module (gnu services) | |
30 | #:use-module (gnu services ci) | |
31 | #:use-module (gnu services web) | |
32 | #:use-module (gnu services networking) | |
33 | #:use-module (guix gexp) | |
34 | #:use-module (guix store) | |
35 | #:export (%test-laminar)) | |
36 | ||
37 | \f | |
38 | (define %laminar-os | |
39 | ;; Operating system under test. | |
40 | (simple-operating-system | |
41 | (service dhcp-client-service-type) | |
42 | (service laminar-service-type))) | |
43 | ||
44 | (define* (run-laminar-test #:optional (http-port 8080)) | |
45 | "Run tests in %LAMINAR-OS, which has laminar running and listening on | |
46 | HTTP-PORT." | |
47 | (define os | |
48 | (marionette-operating-system | |
49 | %laminar-os | |
50 | #:imported-modules '((gnu services herd) | |
51 | (guix combinators)))) | |
52 | ||
53 | (define vm | |
54 | (virtual-machine | |
55 | (operating-system os) | |
56 | (port-forwardings `((,http-port . 8080))))) | |
57 | ||
58 | (define test | |
59 | (with-imported-modules '((gnu build marionette)) | |
60 | #~(begin | |
61 | (use-modules (srfi srfi-11) (srfi srfi-64) | |
62 | (ice-9 match) | |
63 | (gnu build marionette) | |
64 | (web uri) | |
65 | (web client) | |
66 | (web response)) | |
67 | ||
68 | (define marionette | |
69 | ;; Forward the guest's HTTP-PORT, where laminar is listening, to | |
70 | ;; port 8080 in the host. | |
71 | (make-marionette (list #$vm))) | |
72 | ||
73 | (mkdir #$output) | |
74 | (chdir #$output) | |
75 | ||
76 | (test-begin "laminar") | |
77 | ||
78 | (test-assert "service running" | |
79 | (marionette-eval | |
80 | '(begin | |
81 | (use-modules (gnu services herd)) | |
82 | (start-service 'laminar)) | |
83 | marionette)) | |
84 | ||
85 | (define* (retry-on-error f #:key times delay) | |
86 | (let loop ((attempt 1)) | |
87 | (match (catch | |
88 | #t | |
89 | (lambda () | |
90 | (cons #t | |
91 | (f))) | |
92 | (lambda args | |
93 | (cons #f | |
94 | args))) | |
95 | ((#t . return-value) | |
96 | return-value) | |
97 | ((#f . error-args) | |
98 | (if (>= attempt times) | |
99 | error-args | |
100 | (begin | |
101 | (sleep delay) | |
102 | (loop (+ 1 attempt)))))))) | |
103 | ||
104 | (test-equal "http-get" | |
105 | 200 | |
106 | (retry-on-error | |
107 | (lambda () | |
108 | (let-values (((response text) | |
109 | (http-get #$(format | |
110 | #f | |
111 | "http://localhost:~A/" | |
112 | http-port) | |
113 | ;; TODO: Why does decoding fail? | |
114 | #:decode-body? #f))) | |
115 | (response-code response))) | |
116 | #:times 10 | |
117 | #:delay 5)) | |
118 | ||
119 | (test-end) | |
120 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
121 | ||
122 | (gexp->derivation "laminar-test" test)) | |
123 | ||
124 | (define %test-laminar | |
125 | (system-test | |
126 | (name "laminar") | |
127 | (description "Connect to a running Laminar server.") | |
128 | (value (run-laminar-test)))) |