Generate and store system test derivations for all supported systems
Rather than just the native system. I'm not quite sure of the value here, as I guess system tests should behave the same regardless of the way the software is compiled, but this seems like it could be useful, and being explicit about the system the derivation is for is good.
This commit is contained in:
parent
e0f920bb14
commit
c44297b615
8 changed files with 126 additions and 39 deletions
|
|
@ -286,16 +286,24 @@ WHERE job_id = $1"
|
|||
result)))))
|
||||
|
||||
(define (all-inferior-system-tests inf store)
|
||||
(define inferior-%supported-systems
|
||||
(inferior-eval '(@ (guix packages) %supported-systems) inf))
|
||||
|
||||
(define extract
|
||||
'(lambda (store)
|
||||
`(lambda (store)
|
||||
(map
|
||||
(lambda (system-test)
|
||||
(list (system-test-name system-test)
|
||||
(system-test-description system-test)
|
||||
(derivation-file-name
|
||||
(run-with-store store
|
||||
(mbegin %store-monad
|
||||
(system-test-value system-test))))
|
||||
(map (lambda (system)
|
||||
(cons
|
||||
system
|
||||
(parameterize ((%current-system system))
|
||||
(derivation-file-name
|
||||
(run-with-store store
|
||||
(mbegin %store-monad
|
||||
(system-test-value system-test)))))))
|
||||
(list ,@inferior-%supported-systems))
|
||||
(match (system-test-location system-test)
|
||||
(($ <location> file line column)
|
||||
(list file
|
||||
|
|
@ -307,8 +315,10 @@ WHERE job_id = $1"
|
|||
(with-time-logging "getting system tests"
|
||||
(inferior-eval-with-store inf store extract))))
|
||||
|
||||
(for-each (lambda (derivation-file-name)
|
||||
(add-temp-root store derivation-file-name))
|
||||
(for-each (lambda (derivation-file-names-by-system)
|
||||
(for-each (lambda (derivation-file-name)
|
||||
(add-temp-root store derivation-file-name))
|
||||
(map cdr derivation-file-names-by-system)))
|
||||
(map third system-test-data))
|
||||
|
||||
system-test-data))
|
||||
|
|
|
|||
|
|
@ -30,43 +30,55 @@
|
|||
(define (insert-system-tests-for-guix-revision conn
|
||||
guix-revision-id
|
||||
system-test-data)
|
||||
(let ((system-test-ids
|
||||
(insert-missing-data-and-return-all-ids
|
||||
conn
|
||||
"system_tests"
|
||||
'(name description location_id)
|
||||
(map (match-lambda
|
||||
((name description derivation-file-name location-data)
|
||||
(list name
|
||||
description
|
||||
(location->location-id
|
||||
conn
|
||||
(apply location location-data)))))
|
||||
system-test-data)))
|
||||
(derivation-ids
|
||||
(derivation-file-names->derivation-ids
|
||||
conn
|
||||
(map third system-test-data))))
|
||||
(let* ((system-test-ids
|
||||
(insert-missing-data-and-return-all-ids
|
||||
conn
|
||||
"system_tests"
|
||||
'(name description location_id)
|
||||
(map (match-lambda
|
||||
((name description derivation-file-names-by-system location-data)
|
||||
(list name
|
||||
description
|
||||
(location->location-id
|
||||
conn
|
||||
(apply location location-data)))))
|
||||
system-test-data)))
|
||||
(data
|
||||
(append-map
|
||||
(lambda (system-test-id derivation-file-names-by-system)
|
||||
(let ((systems
|
||||
(map car derivation-file-names-by-system))
|
||||
(derivation-ids
|
||||
(derivation-file-names->derivation-ids
|
||||
conn
|
||||
(map cdr derivation-file-names-by-system))))
|
||||
(map (lambda (system derivation-id)
|
||||
(list guix-revision-id
|
||||
system-test-id
|
||||
derivation-id
|
||||
system))
|
||||
systems
|
||||
derivation-ids)))
|
||||
system-test-ids
|
||||
(map third system-test-data))))
|
||||
|
||||
(exec-query
|
||||
conn
|
||||
(string-append
|
||||
"
|
||||
INSERT INTO guix_revision_system_test_derivations
|
||||
(guix_revision_id, system_test_id, derivation_id)
|
||||
(guix_revision_id, system_test_id, derivation_id, system)
|
||||
VALUES "
|
||||
(string-join
|
||||
(map (lambda (system-test-id derivation-id)
|
||||
(simple-format #f "(~A, ~A, ~A)"
|
||||
guix-revision-id
|
||||
system-test-id
|
||||
derivation-id))
|
||||
system-test-ids
|
||||
derivation-ids)
|
||||
(map (lambda (vals)
|
||||
(apply simple-format #f "(~A, ~A, ~A, '~A')"
|
||||
vals))
|
||||
data)
|
||||
", "))))
|
||||
#t)
|
||||
|
||||
(define (select-system-tests-for-guix-revision conn
|
||||
system
|
||||
commit-hash)
|
||||
(define query
|
||||
"
|
||||
|
|
@ -103,7 +115,8 @@ LEFT OUTER JOIN (
|
|||
ON builds.id = latest_build_status.build_id
|
||||
INNER JOIN guix_revisions
|
||||
ON guix_revisions.id = guix_revision_system_test_derivations.guix_revision_id
|
||||
WHERE guix_revisions.commit = $1
|
||||
WHERE guix_revision_system_test_derivations.system = $1 AND
|
||||
guix_revisions.commit = $2
|
||||
GROUP BY system_tests.name, system_tests.description,
|
||||
locations.file, locations.line, locations.column_number,
|
||||
derivations.file_name
|
||||
|
|
@ -125,4 +138,4 @@ ORDER BY name ASC")
|
|||
(assoc-ref build "status"))
|
||||
(vector->list
|
||||
(json-string->scm builds-json))))))
|
||||
(exec-query conn query (list commit-hash))))
|
||||
(exec-query conn query (list system commit-hash))))
|
||||
|
|
|
|||
|
|
@ -216,10 +216,15 @@
|
|||
commit-hash)))
|
||||
(('GET "revision" commit-hash "system-tests")
|
||||
(if (guix-commit-exists? conn commit-hash)
|
||||
(render-revision-system-tests mime-types
|
||||
conn
|
||||
commit-hash
|
||||
#:path-base path)
|
||||
(let ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((system ,parse-system #:default "x86_64-linux")))))
|
||||
(render-revision-system-tests mime-types
|
||||
conn
|
||||
commit-hash
|
||||
parsed-query-parameters
|
||||
#:path-base path))
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash)))
|
||||
|
|
@ -360,6 +365,7 @@
|
|||
(define* (render-revision-system-tests mime-types
|
||||
conn
|
||||
commit-hash
|
||||
query-parameters
|
||||
#:key
|
||||
(path-base "/revision/")
|
||||
(header-text
|
||||
|
|
@ -367,7 +373,10 @@
|
|||
(header-link
|
||||
(string-append "/revision/" commit-hash)))
|
||||
(let ((system-tests
|
||||
(select-system-tests-for-guix-revision conn commit-hash)))
|
||||
(select-system-tests-for-guix-revision
|
||||
conn
|
||||
(assq-ref query-parameters 'system)
|
||||
commit-hash)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
|
|
@ -381,6 +390,8 @@
|
|||
system-tests
|
||||
(git-repositories-containing-commit conn
|
||||
commit-hash)
|
||||
(valid-systems conn)
|
||||
query-parameters
|
||||
#:path-base path-base
|
||||
#:header-text header-text
|
||||
#:header-link header-link))))))
|
||||
|
|
|
|||
|
|
@ -653,6 +653,8 @@
|
|||
(define* (view-revision-system-tests commit-hash
|
||||
system-tests
|
||||
git-repositories
|
||||
valid-systems
|
||||
query-parameters
|
||||
#:key (path-base "/revision/")
|
||||
header-text header-link)
|
||||
(layout
|
||||
|
|
@ -672,6 +674,24 @@
|
|||
(div
|
||||
(@ (class "col-md-12"))
|
||||
(h1 "System tests")
|
||||
(div
|
||||
(@ (class "well"))
|
||||
(form
|
||||
(@ (method "get")
|
||||
(action "")
|
||||
(style "padding-bottom: 0")
|
||||
(class "form-horizontal"))
|
||||
,(form-horizontal-control
|
||||
"System" query-parameters
|
||||
#:options valid-systems
|
||||
#:help-text "Only include system test derivations for this system."
|
||||
#:allow-selecting-multiple-options #f
|
||||
#:font-family "monospace")
|
||||
(div (@ (class "form-group form-group-lg"))
|
||||
(div (@ (class "col-sm-offset-2 col-sm-10"))
|
||||
(button (@ (type "submit")
|
||||
(class "btn btn-lg btn-primary"))
|
||||
"Update results")))))
|
||||
(table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
-- Deploy guix-data-service:guix_revision_system_test_derivations_add_system to pg
|
||||
|
||||
BEGIN;
|
||||
|
||||
ALTER TABLE guix_revision_system_test_derivations ADD COLUMN system varchar;
|
||||
|
||||
-- Assume that existing values are for 'x86_64-linux'
|
||||
UPDATE guix_revision_system_test_derivations SET system = 'x86_64-linux';
|
||||
|
||||
ALTER TABLE guix_revision_system_test_derivations ALTER system SET NOT NULL;
|
||||
|
||||
ALTER TABLE guix_revision_system_test_derivations
|
||||
DROP CONSTRAINT guix_revision_system_test_derivations_pkey;
|
||||
|
||||
ALTER TABLE guix_revision_system_test_derivations
|
||||
ADD CONSTRAINT guix_revision_system_test_derivations_pkey PRIMARY KEY (guix_revision_id, system_test_id, system, derivation_id);
|
||||
|
||||
COMMIT;
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
-- Revert guix-data-service:guix_revision_system_test_derivations_add_system from pg
|
||||
|
||||
BEGIN;
|
||||
|
||||
-- XXX Add DDLs here.
|
||||
|
||||
COMMIT;
|
||||
|
|
@ -52,3 +52,4 @@ allow_including_and_excluding_branches_for_repositories 2020-02-08T11:30:02Z Chr
|
|||
channel_instance_derivations 2020-02-10T07:59:03Z Christopher Baines <mail@cbaines.net> # Add tables to store derivations for channel instances
|
||||
update_build_servers_build_config 2020-02-13T20:07:19Z Christopher Baines <mail@cbaines.net> # Update build_servers_build_config values
|
||||
make_some_constraints_deferrable 2020-02-16T10:54:22Z Christopher Baines <mail@cbaines.net> # Make some constraints deferrable
|
||||
guix_revision_system_test_derivations_add_system 2020-03-19T21:30:33Z Christopher Baines <mail@cbaines.net> # Add a system column to the guix_revision_system_test_derivations table
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
-- Verify guix-data-service:guix_revision_system_test_derivations_add_system on pg
|
||||
|
||||
BEGIN;
|
||||
|
||||
-- XXX Add verifications here.
|
||||
|
||||
ROLLBACK;
|
||||
Loading…
Add table
Add a link
Reference in a new issue