gnu/tests/ci.scm

   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))))