ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-12 06:06:53 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

tests: cuirass: Add an operating system argument.

Browse source 
Rewrite so that "run-cuirass-test" takes an operating-system argument. This is
functionally equivalent.

* gnu/tests/cuirass.scm (%derivation-file, git-service, cow-service,
%cuirass-specs): New variables.
(cuirass-services): New procedure.
(run-cuirass-test): Add an "operating-system" argument.
(%cuirass-test): Adapt it.
(%cuirass-remote-test): Ditto.
This commit is contained in:
Mathieu Othacehe 2021-02-19 19:09:18 +01:00
parent f57b7cea74
commit 25ad6e1d8e
No known key found for this signature in database
GPG key ID: 8354763531769CA6
1 changed files with 126 additions and 116 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

242
gnu/tests/cuirass.scm
View file

@ -31,20 +31,89 @@ (define-module (gnu tests cuirass)
#:use-module (gnu services databases) #:use-module (gnu services databases)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (gnu system nss) #:use-module (gnu system nss)
#:use-module (guix channels)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:export (%cuirass-test #:export (%cuirass-test
%cuirass-remote-test)) %cuirass-remote-test))
(define* (run-cuirass-test name #:key remote-build?) (define %derivation-file
(define %cuirass-specs (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 #~(list
'((#:name . "test") '((#:name . "test")
(#:load-path-inputs . ()) (#:load-path-inputs . ())
(#:package-path-inputs . ()) (#:package-path-inputs . ())
(#:proc-input . "main") (#:proc-input . "main")
(#:proc-file . "derivation.scm") (#:proc-file . "build-aux/cuirass/gnu-system.scm")
(#:proc . main) (#:proc . cuirass-jobs)
(#:proc-args . ()) (#:proc-args . ())
(#:inputs . (((#:name . "main") (#:inputs . (((#:name . "main")
(#:url . "file:///tmp/cuirass-main/") (#:url . "file:///tmp/cuirass-main/")
@ -54,103 +123,29 @@ (define %cuirass-specs
(#:build-outputs . ()) (#:build-outputs . ())
(#:priority . 1)))) (#:priority . 1))))
(define %derivation-file (define* (cuirass-services #:key remote-build?)
(scheme-file (list
"derivation.scm" (service cuirass-service-type
'(begin (cuirass-configuration
(use-modules (guix) (specifications %cuirass-specs)
(srfi srfi-1) (remote-server (and remote-build?
(ice-9 match)) (cuirass-remote-server-configuration)))
(host "0.0.0.0")
(define (derivation->alist store drv) (use-substitutes? #t)))
`((#:derivation . ,(derivation-file-name drv)) (service postgresql-service-type
(#:log . ,(log-file store (derivation-file-name drv))) (postgresql-configuration
(#:outputs . ,(filter-map (lambda (res) (postgresql postgresql-10)))
(match res (service postgresql-role-service-type)))
((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)
(remote-server (and remote-build?
(cuirass-remote-server-configuration)))
(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 (run-cuirass-test name os)
(define os* (define os*
(operating-system (let ((modules '((gnu services herd)
(inherit os) (guix combinators)
(name-service-switch %mdns-host-lookup-nss) (guix build syscalls)
(services (guix build utils))))
(append (if remote-build? (marionette-operating-system
(list os
(service avahi-service-type) #:imported-modules modules)))
(service cuirass-remote-worker-service-type
(cuirass-remote-worker-configuration)))
'())
(operating-system-user-services os)))))
(define cuirass-web-port 8081) (define cuirass-web-port 8081)
(define forward-port 5000) (define forward-port 5000)
@ -219,8 +214,7 @@ (define* (retry f #:key times delay)
#:times 5 #:times 5
#:delay 5))) #:delay 5)))
(test-equal "cuirass-web evaluation" (test-assert "cuirass-web evaluation"
"test"
(begin (begin
(retry (retry
(lambda () (lambda ()
@ -230,8 +224,9 @@ (define* (retry f #:key times delay)
(false-if-exception (false-if-exception
(json-string->scm (json-string->scm
(utf8->string text))))) (utf8->string text)))))
(and result (eq? (and result
(assoc-ref result "specification"))))) (assoc-ref result "id"))
1))))
#:times 5 #:times 5
#:delay 5))) #:delay 5)))
@ -249,11 +244,7 @@ (define* (retry f #:key times delay)
(utf8->string text)))) (utf8->string text))))
(match (vector->list result) (match (vector->list result)
((build) ((build)
(and (string=? (assoc-ref build "job") (string=? (assoc-ref build "job") "test-job"))
"test-job")
(or (not #$remote-build?)
;; Check if the build is started.
(= (assoc-ref build "buildstatus") -1))))
(else #f))))) (else #f)))))
#:times 5 #:times 5
#:delay 10))) #:delay 10)))
@ -264,13 +255,32 @@ (define* (retry f #:key times delay)
(gexp->derivation name test)) (gexp->derivation name test))
(define %cuirass-test (define %cuirass-test
(system-test (let ((os (operating-system
(name "cuirass") (inherit %simple-os)
(description "Connect to a Cuirass server.") (services
(value (run-cuirass-test name)))) (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 (define %cuirass-remote-test
(system-test (let ((os (operating-system
(name "cuirass-remote") (inherit %simple-os)
(description "Connect to a Cuirass server with remote build.") (name-service-switch %mdns-host-lookup-nss)
(value (run-cuirass-test name #:remote-build? #t)))) (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)))))