08/08: tests: Add cuirass test.

[guix-commits]

mothacehe pushed a commit to branch master
in repository guix.

commit f58d0713669fb4f642b381af9536deedf57652a5
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Thu Jan 21 12:18:42 2021 +0100

    tests: Add cuirass test.
---
 gnu/tests/cuirass.scm | 244 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 244 insertions(+)

diff --git a/gnu/tests/cuirass.scm b/gnu/tests/cuirass.scm
new file mode 100644
index 0000000..209e995
--- /dev/null
+++ b/gnu/tests/cuirass.scm
@@ -0,0 +1,244 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests cuirass)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu system install)
+  #:use-module (gnu packages databases)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages version-control)
+  #:use-module (gnu services)
+  #:use-module (gnu services avahi)
+  #:use-module (gnu services base)
+  #:use-module (gnu services cuirass)
+  #:use-module (gnu services databases)
+  #:use-module (gnu services networking)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:export (%cuirass-test))
+
+(define (run-cuirass-test)
+  (define %cuirass-specs
+    #~(list
+       '((#:name . "test")
+         (#:load-path-inputs . ())
+         (#:package-path-inputs . ())
+         (#:proc-input . "main")
+         (#:proc-file . "derivation.scm")
+         (#:proc . main)
+         (#:proc-args . ())
+         (#:inputs . (((#:name . "main")
+                       (#:url . "file:///tmp/cuirass-main/")
+                       (#:load-path . ".")
+                       (#:branch . "master")
+                       (#:no-compile? . #t))))
+         (#:build-outputs . ())
+         (#:priority . 1))))
+
+  (define %derivation-file
+    (scheme-file
+     "derivation.scm"
+     '(begin
+        (use-modules (guix)
+                     (srfi srfi-1)
+                     (ice-9 match))
+
+        (define (derivation->alist store drv)
+          `((#:derivation . ,(derivation-file-name drv))
+            (#:log . ,(log-file store (derivation-file-name drv)))
+            (#:outputs . ,(filter-map (lambda (res)
+                                        (match res
+                                          ((name . path)
+                                           `(,name . ,path))))
+                                      (derivation->output-paths drv)))
+            (#:nix-name . ,(derivation-name drv))
+            (#:system . ,(derivation-system drv))
+            (#:max-silent-time . 3600)
+            (#:timeout . 3600)))
+
+        (define (main store arguments)
+          (let* ((file (plain-file "test" "this is a test derivation"))
+                 (job-name "test-job")
+                 (drv  (run-with-store store
+                         (gexp->derivation
+                          job-name
+                          #~(begin
+                              (mkdir #$output)
+                              (symlink #$file
+                                       (string-append #$output "/file")))))))
+            (list (lambda ()
+                    `((#:job-name . ,job-name)
+                      ,@(derivation->alist store drv)))))))))
+
+  (define os
+    (marionette-operating-system
+     (simple-operating-system
+      (service cuirass-service-type
+               (cuirass-configuration
+                (specifications %cuirass-specs)
+                (host "0.0.0.0")
+                (use-substitutes? #t)))
+      (service dhcp-client-service-type)
+      ;; Create a Git repository to host Cuirass' specification.
+      (simple-service
+       'create-git-directory activation-service-type
+       #~(begin
+           (let* ((git (string-append #$git "/bin/git"))
+                  (main "/tmp/cuirass-main")
+                  (file (string-append main "/derivation.scm")))
+             (mkdir-p main)
+             (with-directory-excursion main
+               (copy-file #$%derivation-file file)
+               (invoke git "config" "--global" "user.email"
+                       "charlie@example.org")
+               (invoke git "config" "--global" "user.name" "A U Thor")
+               (invoke git "init")
+               (invoke git "add" ".")
+               (invoke git "commit" "-m" "That's a commit.")))))
+      ;; The Guix-daemon & Cuirass will complain if the store is
+      ;; read-only. Create a store overlay to solve this issue.
+      (simple-service
+       'mount-cow-store activation-service-type
+       #~(begin
+           (use-modules (guix build syscalls)
+                        (guix build utils))
+           (mkdir-p "/rw-store")
+           (mount "none" "/rw-store" "tmpfs")
+
+           (mkdir-p "/rw-store/upper")
+           (mkdir-p "/rw-store/work")
+           (mount "none" "/gnu/store" "overlay" 0
+                  
"lowerdir=/gnu/store,upperdir=/rw-store/upper,workdir=/rw-store/work")))
+      (service postgresql-service-type
+               (postgresql-configuration
+                (postgresql postgresql-10)))
+      (service postgresql-role-service-type))
+     #:imported-modules '((gnu services herd)
+                          (guix combinators)
+                          (guix build syscalls)
+                          (guix build utils))))
+
+  (define cuirass-web-port 8081)
+  (define forward-port 5000)
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (memory-size 1024)
+     (port-forwardings `((,forward-port . ,cuirass-web-port)))))
+
+  (define test
+    (with-extensions (list guile-json-4)
+      (with-imported-modules '((gnu build marionette))
+        #~(begin
+            (use-modules (srfi srfi-11) (srfi srfi-64)
+                         (gnu build marionette)
+                         (ice-9 match)
+                         (ice-9 rdelim)
+                         (json)
+                         (rnrs bytevectors)
+                         (web client) (web response))
+
+            (define marionette
+              (make-marionette (list #$vm)))
+
+            (define (query path)
+              (http-get
+               (format #f "http://localhost:~a~a";
+                       #$(number->string forward-port)
+                       path)))
+
+            (define* (retry f #:key times delay)
+              (let loop ((attempt 1))
+                (let ((result (f)))
+                  (cond
+                    (result result)
+                    (else
+                     (if (>= attempt times)
+                         #f
+                         (begin
+                           (sleep delay)
+                           (loop (+ 1 attempt)))))))))
+
+            (mkdir #$output)
+            (chdir #$output)
+
+            (test-begin "cuirass")
+
+            ;; Wait for cuirass to be up and running.
+            (test-assert "cuirass running"
+              (marionette-eval
+               '(begin
+                  (use-modules (gnu services herd))
+                  (start-service 'cuirass)
+                  #t)
+               marionette))
+
+            (test-assert "cuirass-web running"
+              (begin
+                (wait-for-tcp-port #$cuirass-web-port marionette)
+                (retry
+                 (lambda ()
+                   (let-values (((response text)
+                                 (query "/")))
+                     (eq? (response-code response) 200)))
+                 #:times 5
+                 #:delay 5)))
+
+            (test-equal "cuirass-web evaluation"
+              "test"
+              (begin
+                (let-values (((response text)
+                              (query "/api/evaluation?id=1")))
+                  (let ((result
+                         (json-string->scm
+                          (utf8->string text))))
+                    (assoc-ref result "specification")))))
+
+            ;; Even though there's a store overlay, the Guix database is not
+            ;; initialized, meaning that we won't be able to perform the
+            ;; build. Check at least that it is queued.
+            (test-assert "cuirass-web build queued"
+              (begin
+                (retry
+                 (lambda ()
+                   (let-values (((response text)
+                                 (query "/api/queue?nr=1")))
+                     (let ((result
+                            (json-string->scm
+                             (utf8->string text))))
+                       (match (vector->list result)
+                         ((build)
+                          (string=? (assoc-ref build "job")
+                                    "test-job"))
+                         (else #f)))))
+                 #:times 5
+                 #:delay 5)))
+
+            (test-end)
+            (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
+
+  (gexp->derivation "cuirass-test" test))
+
+(define %cuirass-test
+  (system-test
+   (name "cuirass")
+   (description "Connect to a Cuirass server.")
+   (value (run-cuirass-test))))