aboutsummaryrefslogtreecommitdiff
path: root/gnu/tests
diff options
context:
space:
mode:
authorMathieu Othacehe <othacehe@gnu.org>2021-03-23 16:41:40 +0100
committerMathieu Othacehe <othacehe@gnu.org>2021-03-23 16:47:47 +0100
commiteee69da3a5c64cbb897e9e923769f12baf916d9e (patch)
treeae4f54d1782ca6a371c4601fc66bd49a65fce25d /gnu/tests
parent8ac7fae8b0aebee01cb2592fd24c49fc0828c019 (diff)
downloadguix-eee69da3a5c64cbb897e9e923769f12baf916d9e.tar
guix-eee69da3a5c64cbb897e9e923769f12baf916d9e.tar.gz
tests: Remove Cuirass tests.
Those tests don't make sense anymore as the Cuirass 1.0 version has removed the possibility to execute a custom registration procedure. * gnu/tests/cuirass.scm: Remove it. * gnu/local.mk (GNU_SYSTEM_MODULES): Ditto.
Diffstat (limited to 'gnu/tests')
-rw-r--r--gnu/tests/cuirass.scm299
1 files changed, 0 insertions, 299 deletions
diff --git a/gnu/tests/cuirass.scm b/gnu/tests/cuirass.scm
deleted file mode 100644
index ea5db34515..0000000000
--- a/gnu/tests/cuirass.scm
+++ /dev/null
@@ -1,299 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020, 2021 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 (gnu system nss)
- #:use-module (guix channels)
- #:use-module (guix gexp)
- #:use-module (guix store)
- #:export (%cuirass-test
- %cuirass-remote-test))
-
-(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 (cuirass-jobs 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 git-service
- ;; 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 "/build-aux/cuirass/gnu-system.scm")))
- (mkdir-p (dirname file))
- (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."))))))
-
-(define cow-service
- ;; 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"))))
-
-(define %cuirass-specs
- #~(list
- '((#:name . "test")
- (#:load-path-inputs . ())
- (#:package-path-inputs . ())
- (#:proc-input . "main")
- (#:proc-file . "build-aux/cuirass/gnu-system.scm")
- (#:proc . cuirass-jobs)
- (#:proc-args . ())
- (#:inputs . (((#:name . "main")
- (#:url . "file:///tmp/cuirass-main/")
- (#:load-path . ".")
- (#:branch . "master")
- (#:no-compile? . #t))))
- (#:build-outputs . ())
- (#:priority . 1))))
-
-(define* (cuirass-services #:key remote-build?)
- (list
- (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)))))
-
-(define (run-cuirass-test name os)
- (define os*
- (let ((modules '((gnu services herd)
- (guix combinators)
- (guix build syscalls)
- (guix build utils))))
- (marionette-operating-system
- os
- #:imported-modules modules)))
-
- (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")
-
- ;; XXX: Shepherd reads the config file *before* binding its
- ;; control socket, so /var/run/shepherd/socket might not exist yet
- ;; when the 'marionette' service is started.
- (test-assert "shepherd socket ready"
- (marionette-eval
- `(begin
- (use-modules (gnu services herd))
- (let loop ((i 10))
- (cond ((file-exists? (%shepherd-socket-file))
- #t)
- ((> i 0)
- (sleep 1)
- (loop (- i 1)))
- (else
- 'failure))))
- marionette))
-
- ;; 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-assert "cuirass-web evaluation"
- (begin
- (retry
- (lambda ()
- (let-values (((response text)
- (query "/api/evaluation?id=1")))
- (let ((result
- (false-if-exception
- (json-string->scm
- (utf8->string text)))))
- (eq? (and result
- (assoc-ref result "id"))
- 1))))
- #: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
- ;; 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 10)))
-
- (test-end)
- (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
-
- (gexp->derivation name test))
-
-(define %cuirass-test
- (let ((os (operating-system
- (inherit %simple-os)
- (services
- (append (list cow-service
- (service dhcp-client-service-type)
- git-service)
- (cuirass-services)
- (operating-system-user-services %simple-os))))))
- (system-test
- (name "cuirass")
- (description "Connect to a Cuirass server.")
- (value
- (run-cuirass-test name os)))))
-
-(define %cuirass-remote-test
- (let ((os (operating-system
- (inherit %simple-os)
- (name-service-switch %mdns-host-lookup-nss)
- (services
- (append (list (service avahi-service-type)
- cow-service
- (service dhcp-client-service-type)
- git-service)
- (cuirass-services #:remote-build? #t)
- (operating-system-user-services %simple-os))))))
- (system-test
- (name "cuirass-remote")
- (description "Connect to a Cuirass server with remote build.")
- (value (run-cuirass-test name os)))))