You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

664 lines
20 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2017, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2017, 2019 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. (define-module (gnu tests web)
  23. #:use-module (gnu tests)
  24. #:use-module (gnu system)
  25. #:use-module (gnu system file-systems)
  26. #:use-module (gnu system shadow)
  27. #:use-module (gnu system vm)
  28. #:use-module (gnu services)
  29. #:use-module (gnu services web)
  30. #:use-module (gnu services databases)
  31. #:use-module (gnu services getmail)
  32. #:use-module (gnu services networking)
  33. #:use-module (gnu services shepherd)
  34. #:use-module (gnu services mail)
  35. #:use-module (gnu packages databases)
  36. #:use-module (gnu packages patchutils)
  37. #:use-module (gnu packages python)
  38. #:use-module (gnu packages web)
  39. #:use-module (guix packages)
  40. #:use-module (guix modules)
  41. #:use-module (guix records)
  42. #:use-module (guix gexp)
  43. #:use-module (guix store)
  44. #:use-module (guix utils)
  45. #:use-module (ice-9 match)
  46. #:export (%test-httpd
  47. %test-nginx
  48. %test-varnish
  49. %test-php-fpm
  50. %test-hpcguix-web
  51. %test-tailon
  52. %test-patchwork))
  53. (define %index.html-contents
  54. ;; Contents of the /index.html file.
  55. "Hello, guix!")
  56. (define %make-http-root
  57. ;; Create our server root in /srv.
  58. #~(begin
  59. (mkdir "/srv")
  60. (mkdir "/srv/http")
  61. (call-with-output-file "/srv/http/index.html"
  62. (lambda (port)
  63. (display #$%index.html-contents port)))))
  64. (define* (run-webserver-test name test-os #:key (log-file #f) (http-port 8080))
  65. "Run tests in %NGINX-OS, which has nginx running and listening on
  66. HTTP-PORT."
  67. (define os
  68. (marionette-operating-system
  69. test-os
  70. #:imported-modules '((gnu services herd)
  71. (guix combinators))))
  72. (define forwarded-port 8080)
  73. (define vm
  74. (virtual-machine
  75. (operating-system os)
  76. (port-forwardings `((,http-port . ,forwarded-port)))))
  77. (define test
  78. (with-imported-modules '((gnu build marionette))
  79. #~(begin
  80. (use-modules (srfi srfi-11) (srfi srfi-64)
  81. (gnu build marionette)
  82. (web uri)
  83. (web client)
  84. (web response))
  85. (define marionette
  86. (make-marionette (list #$vm)))
  87. (mkdir #$output)
  88. (chdir #$output)
  89. (test-begin #$name)
  90. (test-assert #$(string-append name " service running")
  91. (marionette-eval
  92. '(begin
  93. (use-modules (gnu services herd))
  94. (match (start-service '#$(string->symbol name))
  95. (#f #f)
  96. (('service response-parts ...)
  97. (match (assq-ref response-parts 'running)
  98. ((#t) #t)
  99. ((pid) (number? pid))))))
  100. marionette))
  101. (test-assert "HTTP port ready"
  102. (wait-for-tcp-port #$forwarded-port marionette))
  103. ;; Retrieve the index.html file we put in /srv.
  104. (test-equal "http-get"
  105. '(200 #$%index.html-contents)
  106. (let-values
  107. (((response text)
  108. (http-get #$(simple-format
  109. #f "http://localhost:~A/index.html" forwarded-port)
  110. #:decode-body? #t)))
  111. (list (response-code response) text)))
  112. #$@(if log-file
  113. `((test-assert ,(string-append "log file exists " log-file)
  114. (marionette-eval
  115. '(file-exists? ,log-file)
  116. marionette)))
  117. '())
  118. (test-end)
  119. (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
  120. (gexp->derivation (string-append name "-test") test))
  121. ;;;
  122. ;;; HTTPD
  123. ;;;
  124. (define %httpd-os
  125. (simple-operating-system
  126. (service dhcp-client-service-type)
  127. (service httpd-service-type
  128. (httpd-configuration
  129. (config
  130. (httpd-config-file
  131. (listen '("8080"))))))
  132. (simple-service 'make-http-root activation-service-type
  133. %make-http-root)))
  134. (define %test-httpd
  135. (system-test
  136. (name "httpd")
  137. (description "Connect to a running HTTPD server.")
  138. (value (run-webserver-test name %httpd-os
  139. #:log-file "/var/log/httpd/error_log"))))
  140. ;;;
  141. ;;; NGINX
  142. ;;;
  143. (define %nginx-servers
  144. ;; Server blocks.
  145. (list (nginx-server-configuration
  146. (listen '("8080")))))
  147. (define %nginx-os
  148. ;; Operating system under test.
  149. (simple-operating-system
  150. (service dhcp-client-service-type)
  151. (service nginx-service-type
  152. (nginx-configuration
  153. (log-directory "/var/log/nginx")
  154. (server-blocks %nginx-servers)))
  155. (simple-service 'make-http-root activation-service-type
  156. %make-http-root)))
  157. (define %test-nginx
  158. (system-test
  159. (name "nginx")
  160. (description "Connect to a running NGINX server.")
  161. (value (run-webserver-test name %nginx-os
  162. #:log-file "/var/log/nginx/access.log"))))
  163. ;;;
  164. ;;; Varnish
  165. ;;;
  166. (define %varnish-vcl
  167. (mixed-text-file
  168. "varnish-test.vcl"
  169. "vcl 4.0;
  170. backend dummy { .host = \"127.1.1.1\"; }
  171. sub vcl_recv { return(synth(200, \"OK\")); }
  172. sub vcl_synth {
  173. synthetic(\"" %index.html-contents "\");
  174. set resp.http.Content-Type = \"text/plain\";
  175. return(deliver);
  176. }"))
  177. (define %varnish-os
  178. (simple-operating-system
  179. (service dhcp-client-service-type)
  180. ;; Pretend to be a web server that serves %index.html-contents.
  181. (service varnish-service-type
  182. (varnish-configuration
  183. (name "/tmp/server")
  184. ;; Use a small VSL buffer to fit in the test VM.
  185. (parameters '(("vsl_space" . "4M")))
  186. (vcl %varnish-vcl)))
  187. ;; Proxy the "server" using the builtin configuration.
  188. (service varnish-service-type
  189. (varnish-configuration
  190. (parameters '(("vsl_space" . "4M")))
  191. (backend "localhost:80")
  192. (listen '(":8080"))))))
  193. (define %test-varnish
  194. (system-test
  195. (name "varnish")
  196. (description "Test the Varnish Cache server.")
  197. (value (run-webserver-test "varnish-default" %varnish-os))))
  198. ;;;
  199. ;;; PHP-FPM
  200. ;;;
  201. (define %make-php-fpm-http-root
  202. ;; Create our server root in /srv.
  203. #~(begin
  204. (mkdir "/srv")
  205. (call-with-output-file "/srv/index.php"
  206. (lambda (port)
  207. (display "<?php
  208. phpinfo();
  209. echo(\"Computed by php:\".((string)(2+3)));
  210. ?>\n" port)))))
  211. (define %php-fpm-nginx-server-blocks
  212. (list (nginx-server-configuration
  213. (root "/srv")
  214. (locations
  215. (list (nginx-php-location)))
  216. (listen '("8042"))
  217. (ssl-certificate #f)
  218. (ssl-certificate-key #f))))
  219. (define %php-fpm-os
  220. ;; Operating system under test.
  221. (simple-operating-system
  222. (service dhcp-client-service-type)
  223. (service php-fpm-service-type)
  224. (service nginx-service-type
  225. (nginx-configuration
  226. (server-blocks %php-fpm-nginx-server-blocks)))
  227. (simple-service 'make-http-root activation-service-type
  228. %make-php-fpm-http-root)))
  229. (define* (run-php-fpm-test #:optional (http-port 8042))
  230. "Run tests in %PHP-FPM-OS, which has nginx running and listening on
  231. HTTP-PORT, along with php-fpm."
  232. (define os
  233. (marionette-operating-system
  234. %php-fpm-os
  235. #:imported-modules '((gnu services herd)
  236. (guix combinators))))
  237. (define vm
  238. (virtual-machine
  239. (operating-system os)
  240. (port-forwardings `((8080 . ,http-port)))))
  241. (define test
  242. (with-imported-modules '((gnu build marionette)
  243. (guix build utils))
  244. #~(begin
  245. (use-modules (srfi srfi-11) (srfi srfi-64)
  246. (gnu build marionette)
  247. (web uri)
  248. (web client)
  249. (web response))
  250. (define marionette
  251. (make-marionette (list #$vm)))
  252. (mkdir #$output)
  253. (chdir #$output)
  254. (test-begin "php-fpm")
  255. (test-assert "php-fpm running"
  256. (marionette-eval
  257. '(begin
  258. (use-modules (gnu services herd))
  259. (match (start-service 'php-fpm)
  260. (#f #f)
  261. (('service response-parts ...)
  262. (match (assq-ref response-parts 'running)
  263. ((pid) (number? pid))))))
  264. marionette))
  265. (test-assert "nginx running"
  266. (marionette-eval
  267. '(begin
  268. (use-modules (gnu services herd))
  269. (start-service 'nginx))
  270. marionette))
  271. (test-equal "http-get"
  272. 200
  273. (let-values (((response text)
  274. (http-get "http://localhost:8080/index.php"
  275. #:decode-body? #t)))
  276. (response-code response)))
  277. (test-equal "php computed result is sent"
  278. "Computed by php:5"
  279. (let-values (((response text)
  280. (http-get "http://localhost:8080/index.php"
  281. #:decode-body? #t)))
  282. (begin
  283. (use-modules (ice-9 regex))
  284. (let ((matches (string-match "Computed by php:5" text)))
  285. (and matches
  286. (match:substring matches 0))))))
  287. (test-end)
  288. (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
  289. (gexp->derivation "php-fpm-test" test))
  290. (define %test-php-fpm
  291. (system-test
  292. (name "php-fpm")
  293. (description "Test PHP-FPM through nginx.")
  294. (value (run-php-fpm-test))))
  295. ;;;
  296. ;;; hpcguix-web
  297. ;;;
  298. (define* (run-hpcguix-web-server-test name test-os)
  299. "Run tests in %HPCGUIX-WEB-OS, which has hpcguix-web running."
  300. (define os
  301. (marionette-operating-system
  302. test-os
  303. #:imported-modules '((gnu services herd)
  304. (guix combinators))))
  305. (define vm
  306. (virtual-machine
  307. (operating-system os)
  308. (port-forwardings '((8080 . 5000)))))
  309. (define test
  310. (with-imported-modules '((gnu build marionette))
  311. #~(begin
  312. (use-modules (srfi srfi-11) (srfi srfi-64)
  313. (gnu build marionette)
  314. (web uri)
  315. (web client)
  316. (web response))
  317. (define marionette
  318. (make-marionette (list #$vm)))
  319. (mkdir #$output)
  320. (chdir #$output)
  321. (test-begin #$name)
  322. (test-assert "hpcguix-web running"
  323. (marionette-eval
  324. '(begin
  325. (use-modules (gnu services herd))
  326. (match (start-service 'hpcguix-web)
  327. (#f #f)
  328. (('service response-parts ...)
  329. (match (assq-ref response-parts 'running)
  330. ((pid) (number? pid))))))
  331. marionette))
  332. (test-equal "http-get"
  333. 200
  334. (begin
  335. (wait-for-tcp-port 5000 marionette)
  336. (let-values (((response text)
  337. (http-get "http://localhost:8080")))
  338. (response-code response))))
  339. (test-end)
  340. (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
  341. (gexp->derivation (string-append name "-test") test))
  342. (define %hpcguix-web-specs
  343. ;; Server config gexp.
  344. #~(define site-config
  345. (hpcweb-configuration
  346. (title-prefix "[TEST] HPCGUIX-WEB"))))
  347. (define %hpcguix-web-os
  348. (simple-operating-system
  349. (service dhcp-client-service-type)
  350. (service hpcguix-web-service-type
  351. (hpcguix-web-configuration
  352. (specs %hpcguix-web-specs)))))
  353. (define %test-hpcguix-web
  354. (system-test
  355. (name "hpcguix-web")
  356. (description "Connect to a running hpcguix-web server.")
  357. (value (run-hpcguix-web-server-test name %hpcguix-web-os))))
  358. (define %tailon-os
  359. ;; Operating system under test.
  360. (simple-operating-system
  361. (service dhcp-client-service-type)
  362. (service tailon-service-type
  363. (tailon-configuration
  364. (config-file
  365. (tailon-configuration-file
  366. (bind "0.0.0.0:8080")))))))
  367. (define* (run-tailon-test #:optional (http-port 8081))
  368. "Run tests in %TAILON-OS, which has tailon running and listening on
  369. HTTP-PORT."
  370. (define os
  371. (marionette-operating-system
  372. %tailon-os
  373. #:imported-modules '((gnu services herd)
  374. (guix combinators))))
  375. (define vm
  376. (virtual-machine
  377. (operating-system os)
  378. (port-forwardings `((,http-port . 8080)))))
  379. (define test
  380. (with-imported-modules '((gnu build marionette))
  381. #~(begin
  382. (use-modules (srfi srfi-11) (srfi srfi-64)
  383. (ice-9 match)
  384. (gnu build marionette)
  385. (web uri)
  386. (web client)
  387. (web response))
  388. (define marionette
  389. ;; Forward the guest's HTTP-PORT, where tailon is listening, to
  390. ;; port 8080 in the host.
  391. (make-marionette (list #$vm)))
  392. (mkdir #$output)
  393. (chdir #$output)
  394. (test-begin "tailon")
  395. (test-assert "service running"
  396. (marionette-eval
  397. '(begin
  398. (use-modules (gnu services herd))
  399. (start-service 'tailon))
  400. marionette))
  401. (define* (retry-on-error f #:key times delay)
  402. (let loop ((attempt 1))
  403. (match (catch
  404. #t
  405. (lambda ()
  406. (cons #t
  407. (f)))
  408. (lambda args
  409. (cons #f
  410. args)))
  411. ((#t . return-value)
  412. return-value)
  413. ((#f . error-args)
  414. (if (>= attempt times)
  415. error-args
  416. (begin
  417. (sleep delay)
  418. (loop (+ 1 attempt))))))))
  419. (test-equal "http-get"
  420. 200
  421. (retry-on-error
  422. (lambda ()
  423. (let-values (((response text)
  424. (http-get #$(format
  425. #f
  426. "http://localhost:~A/"
  427. http-port)
  428. #:decode-body? #t)))
  429. (response-code response)))
  430. #:times 10
  431. #:delay 5))
  432. (test-end)
  433. (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
  434. (gexp->derivation "tailon-test" test))
  435. (define %test-tailon
  436. (system-test
  437. (name "tailon")
  438. (description "Connect to a running Tailon server.")
  439. (value (run-tailon-test))))
  440. ;;;
  441. ;;; Patchwork
  442. ;;;
  443. (define (patchwork-initial-database-setup-service configuration)
  444. (define start-gexp
  445. #~(lambda ()
  446. (let ((pid (primitive-fork))
  447. (postgres (getpwnam "postgres")))
  448. (if (eq? pid 0)
  449. (dynamic-wind
  450. (const #t)
  451. (lambda ()
  452. (setgid (passwd:gid postgres))
  453. (setuid (passwd:uid postgres))
  454. (primitive-exit
  455. (if (and
  456. (zero?
  457. (system* #$(file-append postgresql "/bin/createuser")
  458. #$(patchwork-database-configuration-user
  459. configuration)))
  460. (zero?
  461. (system* #$(file-append postgresql "/bin/createdb")
  462. "-O"
  463. #$(patchwork-database-configuration-user
  464. configuration)
  465. #$(patchwork-database-configuration-name
  466. configuration))))
  467. 0
  468. 1)))
  469. (lambda ()
  470. (primitive-exit 1)))
  471. (zero? (cdr (waitpid pid)))))))
  472. (shepherd-service
  473. (requirement '(postgres))
  474. (provision '(patchwork-postgresql-user-and-database))
  475. (start start-gexp)
  476. (stop #~(const #f))
  477. (respawn? #f)
  478. (documentation "Setup patchwork database.")))
  479. (define (patchwork-os patchwork)
  480. (simple-operating-system
  481. (service dhcp-client-service-type)
  482. (service httpd-service-type
  483. (httpd-configuration
  484. (config
  485. (httpd-config-file
  486. (listen '("8080"))))))
  487. (service postgresql-service-type)
  488. (service patchwork-service-type
  489. (patchwork-configuration
  490. (patchwork patchwork)
  491. (domain "localhost")
  492. (settings-module
  493. (patchwork-settings-module
  494. (allowed-hosts (list domain))
  495. (default-from-email "")))
  496. (getmail-retriever-config
  497. (getmail-retriever-configuration
  498. (type "SimpleIMAPSSLRetriever")
  499. (server "imap.example.com")
  500. (port 993)
  501. (username "username")
  502. (password "password")
  503. (extra-parameters
  504. '((mailboxes . ("INBOX"))))))))
  505. (simple-service 'patchwork-database-setup
  506. shepherd-root-service-type
  507. (list
  508. (patchwork-initial-database-setup-service
  509. (patchwork-database-configuration))))))
  510. (define (run-patchwork-test patchwork)
  511. "Run tests in %NGINX-OS, which has nginx running and listening on
  512. HTTP-PORT."
  513. (define os
  514. (marionette-operating-system
  515. (patchwork-os patchwork)
  516. #:imported-modules '((gnu services herd)
  517. (guix combinators))))
  518. (define forwarded-port 8080)
  519. (define vm
  520. (virtual-machine
  521. (operating-system os)
  522. (port-forwardings `((8080 . ,forwarded-port)))))
  523. (define test
  524. (with-imported-modules '((gnu build marionette))
  525. #~(begin
  526. (use-modules (srfi srfi-11) (srfi srfi-64)
  527. (gnu build marionette)
  528. (web uri)
  529. (web client)
  530. (web response))
  531. (define marionette
  532. (make-marionette (list #$vm)))
  533. (mkdir #$output)
  534. (chdir #$output)
  535. (test-begin "patchwork")
  536. (test-assert "patchwork-postgresql-user-and-service started"
  537. (marionette-eval
  538. '(begin
  539. (use-modules (gnu services herd))
  540. (match (start-service 'patchwork-postgresql-user-and-database)
  541. (#f #f)
  542. (('service response-parts ...)
  543. (match (assq-ref response-parts 'running)
  544. ((#t) #t)
  545. ((pid) (number? pid))))))
  546. marionette))
  547. (test-assert "httpd running"
  548. (marionette-eval
  549. '(begin
  550. (use-modules (gnu services herd))
  551. (start-service 'httpd))
  552. marionette))
  553. (test-equal "http-get"
  554. 200
  555. (let-values
  556. (((response text)
  557. (http-get #$(simple-format
  558. #f "http://localhost:~A/" forwarded-port)
  559. #:decode-body? #t)))
  560. (response-code response)))
  561. (test-end)
  562. (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
  563. (gexp->derivation "patchwork-test" test))
  564. (define %test-patchwork
  565. (system-test
  566. (name "patchwork")
  567. (description "Connect to a running Patchwork service.")
  568. (value (run-patchwork-test patchwork))))