ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

tests: cuirass: Add Cuirass remote test.

Browse source 
* gnu/tests/cuirass.scm (run-cuirass-test): Add "name" and "remote-build?"
arguments.
(%cuirass-test): Adapt it.
(%cuirass-remote-test): New variable.
This commit is contained in:
Mathieu Othacehe 2021-01-29 11:35:03 +01:00
parent a80d489227
commit df656c1518
No known key found for this signature in database
GPG key ID: 8354763531769CA6
1 changed files with 53 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

74
gnu/tests/cuirass.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -30,11 +30,13 @@ (define-module (gnu tests cuirass)
#:use-module (gnu services cuirass)
#:use-module (gnu services databases)
#:use-module (gnu services networking)
#:use-module (gnu system nss)
#:use-module (guix gexp)
#:use-module (guix store)
#:export (%cuirass-test))
#:export (%cuirass-test
%cuirass-remote-test))
(define (run-cuirass-test)
(define* (run-cuirass-test name #:key remote-build?)
(define %cuirass-specs
#~(list
'((#:name . "test")
@ -93,6 +95,8 @@ (define os
(service cuirass-service-type
(cuirass-configuration
(specifications %cuirass-specs)
(remote-server (and remote-build?
(cuirass-remote-server-configuration)))
(host "0.0.0.0")
(use-substitutes? #t)))
(service dhcp-client-service-type)
@ -135,12 +139,25 @@ (define os
(guix build syscalls)
(guix build utils))))
(define os*
(operating-system
(inherit os)
(name-service-switch %mdns-host-lookup-nss)
(services
(append (if remote-build?
(list
(service avahi-service-type)
(service cuirass-remote-worker-service-type
(cuirass-remote-worker-configuration)))
'())
(operating-system-user-services os)))))
(define cuirass-web-port 8081)
(define forward-port 5000)
(define vm
(virtual-machine
(operating-system os)
(operating-system os*)
(memory-size 1024)
(port-forwardings `((,forward-port . ,cuirass-web-port)))))
@ -169,13 +186,13 @@ (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)))))))))
(result result)
(else
(if (>= attempt times)
#f
(begin
(sleep delay)
(loop (+ 1 attempt)))))))))
(mkdir #$output)
(chdir #$output)
@ -205,12 +222,18 @@ (define* (retry f #:key times delay)
(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")))))
(retry
(lambda ()
(let-values (((response text)
(query "/api/evaluation?id=1")))
(let ((result
(false-if-exception
(json-string->scm
(utf8->string text)))))
(and result
(assoc-ref result "specification")))))
#:times 5
#:delay 5)))
;; Even though there's a store overlay, the Guix database is not
;; initialized, meaning that we won't be able to perform the
@ -226,8 +249,11 @@ (define* (retry f #:key times delay)
(utf8->string text))))
(match (vector->list result)
((build)
(string=? (assoc-ref build "job")
"test-job"))
(and (string=? (assoc-ref build "job")
"test-job")
(or (not #$remote-build?)
;; Check if the build is started.
(= (assoc-ref build "buildstatus") -1))))
(else #f)))))
#:times 5
#:delay 5)))
@ -235,10 +261,16 @@ (define* (retry f #:key times delay)
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))))
(gexp->derivation "cuirass-test" test))
(gexp->derivation name test))
(define %cuirass-test
(system-test
(name "cuirass")
(description "Connect to a Cuirass server.")
(value (run-cuirass-test))))
(value (run-cuirass-test name))))
(define %cuirass-remote-test
(system-test
(name "cuirass-remote")
(description "Connect to a Cuirass server with remote build.")
(value (run-cuirass-test name #:remote-build? #t))))