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.

8 files changed, 126 insertions, 39 deletions

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index b554f99..d5a54f9 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -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))
diff --git a/guix-data-service/model/system-test.scm b/guix-data-service/model/system-test.scm
index 87bb647..090ba58 100644
--- a/guix-data-service/model/system-test.scm
+++ b/guix-data-service/model/system-test.scm
@@ -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))))
diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm
index 46b69d9..57156a4 100644
--- a/guix-data-service/web/revision/controller.scm
+++ b/guix-data-service/web/revision/controller.scm
@@ -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))))))
diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm
index 4de9a76..a199197 100644
--- a/guix-data-service/web/revision/html.scm
+++ b/guix-data-service/web/revision/html.scm
@@ -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
diff --git a/sqitch/deploy/guix_revision_system_test_derivations_add_system.sql b/sqitch/deploy/guix_revision_system_test_derivations_add_system.sql
new file mode 100644
index 0000000..43aa9b4
--- /dev/null
+++ b/sqitch/deploy/guix_revision_system_test_derivations_add_system.sql
@@ -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;
diff --git a/sqitch/revert/guix_revision_system_test_derivations_add_system.sql b/sqitch/revert/guix_revision_system_test_derivations_add_system.sql
new file mode 100644
index 0000000..cfb69f9
--- /dev/null
+++ b/sqitch/revert/guix_revision_system_test_derivations_add_system.sql
@@ -0,0 +1,7 @@
+-- Revert guix-data-service:guix_revision_system_test_derivations_add_system from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index 891d595..975d7ee 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -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
diff --git a/sqitch/verify/guix_revision_system_test_derivations_add_system.sql b/sqitch/verify/guix_revision_system_test_derivations_add_system.sql
new file mode 100644
index 0000000..db42d8d
--- /dev/null
+++ b/sqitch/verify/guix_revision_system_test_derivations_add_system.sql
@@ -0,0 +1,7 @@
+-- Verify guix-data-service:guix_revision_system_test_derivations_add_system on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;