;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020, 2021 Mathieu Othacehe ;;; ;;; 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 . (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 %cuirass-simple-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") (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))))) (define simple-cuirass-service (service cuirass-service-type (cuirass-configuration (specifications (simple-cuirass-configuration->specs (simple-cuirass-configuration (build 'all) (channels (list (channel (name 'guix) (url "file:///tmp/cuirass-main/"))))))) (host "0.0.0.0") (use-substitutes? #t)))) (define %cuirass-simple-test (let ((os (operating-system (inherit %simple-os) (services (append (list cow-service (service dhcp-client-service-type) git-service simple-cuirass-service) (operating-system-user-services %simple-os)))))) (system-test (name "cuirass-simple") (description "Connect to a simple Cuirass server.") (value (run-cuirass-test name os)))))