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.

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
+                (map (lambda (system)
-                 (run-with-store store
+                       (cons
-                   (mbegin %store-monad
+                        system
-                     (system-test-value system-test))))
+                        (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)
+    (for-each (lambda (derivation-file-names-by-system)
-                (add-temp-root store derivation-file-name))
+                (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))

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
+  (let* ((system-test-ids
-         (insert-missing-data-and-return-all-ids
+          (insert-missing-data-and-return-all-ids
-          conn
+           conn
-          "system_tests"
+           "system_tests"
-          '(name description location_id)
+           '(name description location_id)
-          (map (match-lambda
+           (map (match-lambda
-                 ((name description derivation-file-name location-data)
+                  ((name description derivation-file-names-by-system location-data)
-                  (list name
+                   (list name
-                        description
+                         description
-                        (location->location-id
+                         (location->location-id
-                         conn
+                          conn
-                         (apply location location-data)))))
+                          (apply location location-data)))))
-               system-test-data)))
+                system-test-data)))
-        (derivation-ids
+         (data
-         (derivation-file-names->derivation-ids
+          (append-map
-          conn
+           (lambda (system-test-id derivation-file-names-by-system)
-          (map third system-test-data))))
+             (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)
+       (map (lambda (vals)
-              (simple-format #f "(~A, ~A, ~A)"
+              (apply simple-format #f "(~A, ~A, ~A, '~A')"
-                             guix-revision-id
+                     vals))
-                             system-test-id
+            data)
-                             derivation-id))
-            system-test-ids
-            derivation-ids)
        ", "))))
   #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))))

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
+         (let ((parsed-query-parameters
-                                       conn
+                (parse-query-parameters
-                                       commit-hash
+                 request
-                                       #:path-base path)
+                 `((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))))))

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

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;

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;

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

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;