gnu/tests/web.scm

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