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.

4 files changed, 93 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