Add page for looking at the history of a system test

This should be useful for looking at when system tests break.

3 files changed, 327 insertions, 1 deletions

diff --git a/guix-data-service/model/system-test.scm b/guix-data-service/model/system-test.scm
index e78f5a1..3a37cd4 100644
--- a/guix-data-service/model/system-test.scm
+++ b/guix-data-service/model/system-test.scm
@@ -25,7 +25,9 @@
   #:use-module (guix-data-service model location)
   #:use-module (guix-data-service model derivation)
   #:export (insert-system-tests-for-guix-revision
-            select-system-tests-for-guix-revision))
+
+            select-system-tests-for-guix-revision
+            system-test-derivations-for-branch))
 
 (define (insert-system-tests-for-guix-revision conn
                                                guix-revision-id
@@ -137,3 +139,102 @@ ORDER BY name ASC")
                     (vector->list
                      (json-string->scm builds-json))))))
    (exec-query conn query (list system commit-hash))))
+
+(define (system-test-derivations-for-branch conn
+                                            git-repository-id
+                                            branch-name
+                                            system
+                                            system-test-name)
+  (define query
+    "
+SELECT derivations.file_name,
+       first_guix_revisions.commit,
+       data2.first_datetime,
+       last_guix_revisions.commit,
+       data2.last_datetime,
+       JSON_AGG(
+         json_build_object(
+           'build_server_id', builds.build_server_id,
+           'build_server_build_id', builds.build_server_build_id,
+           'status',  latest_build_status.status,
+           'timestamp',  latest_build_status.timestamp,
+           'build_for_equivalent_derivation',
+           builds.derivation_file_name != derivations.file_name
+         )
+         ORDER BY latest_build_status.timestamp
+       ) AS builds
+FROM (
+  SELECT DISTINCT
+      derivation_id,
+      first_value(guix_revision_id)
+        OVER derivation_window AS first_guix_revision_id,
+      first_value(datetime)
+        OVER derivation_window AS first_datetime,
+      last_value(guix_revision_id)
+        OVER derivation_window AS last_guix_revision_id,
+      last_value(datetime)
+        OVER derivation_window AS last_datetime
+  FROM (
+    SELECT guix_revision_id,
+           git_branches.datetime,
+           derivation_id
+    FROM guix_revision_system_test_derivations
+    INNER JOIN system_tests
+      ON guix_revision_system_test_derivations.system_test_id = system_tests.id
+    INNER JOIN guix_revisions
+      ON guix_revisions.id = guix_revision_id
+    INNER JOIN git_branches
+      ON guix_revisions.git_repository_id = git_branches.git_repository_id
+     AND git_branches.commit = guix_revisions.commit
+    WHERE system_tests.name = $1
+      AND guix_revisions.git_repository_id = $2
+      AND git_branches.name = $3
+      AND system = $4
+  ) AS data1
+  WINDOW derivation_window AS (
+    PARTITION BY data1.derivation_id
+    ORDER BY data1.datetime ASC
+    RANGE BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING
+  )
+) AS data2
+INNER JOIN guix_revisions AS first_guix_revisions
+  ON first_guix_revisions.id = data2.first_guix_revision_id
+INNER JOIN guix_revisions AS last_guix_revisions
+  ON last_guix_revisions.id = data2.last_guix_revision_id
+INNER JOIN derivations
+  ON derivations.id = data2.derivation_id
+INNER JOIN derivations_by_output_details_set
+  ON derivations_by_output_details_set.derivation_id = derivations.id
+LEFT OUTER JOIN builds
+  ON derivations_by_output_details_set.derivation_output_details_set_id =
+     builds.derivation_output_details_set_id
+LEFT OUTER JOIN latest_build_status
+  ON builds.id = latest_build_status.build_id
+GROUP BY 1, 2, 3, 4, 5
+ORDER BY data2.first_datetime DESC")
+
+  (map (match-lambda
+         ((derivation-file-name
+           first-guix-revision-commit
+           first-datetime
+           last-guix-revision-commit
+           last-datetime
+           builds-json)
+          (list derivation-file-name
+                first-guix-revision-commit
+                first-datetime
+                last-guix-revision-commit
+                last-datetime
+                (if (string-null? builds-json)
+                    '()
+                    (filter (lambda (build)
+                              (number? (assoc-ref build "build_server_id")))
+                            (vector->list
+                             (json-string->scm builds-json)))))))
+       (exec-query
+        conn
+        query
+        (list system-test-name
+              (number->string git-repository-id)
+              branch-name
+              system))))
diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm
index c9f90d1..e79cc7f 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -28,6 +28,7 @@
   #:use-module (guix-data-service model build-server)
   #:use-module (guix-data-service model derivation)
   #:use-module (guix-data-service model package)
+  #:use-module (guix-data-service model system-test)
   #:use-module (guix-data-service model git-branch)
   #:use-module (guix-data-service model git-repository)
   #:use-module (guix-data-service web view html)
@@ -201,6 +202,56 @@
                                            repository-id
                                            branch-name
                                            package-name))
+    (('GET "repository" repository-id "branch" branch-name
+           "system-test" system-test-name)
+     (let ((parsed-query-parameters
+            (parse-query-parameters
+             request
+             `((system ,parse-system #:default "x86_64-linux")))))
+       (letpar& ((system-test-history
+                  (with-thread-postgresql-connection
+                   (lambda (conn)
+                     (system-test-derivations-for-branch
+                      conn
+                      (string->number repository-id)
+                      branch-name
+                      (assq-ref parsed-query-parameters
+                                'system)
+                      system-test-name))))
+                 (valid-systems
+                  (with-thread-postgresql-connection valid-systems)))
+         (case (most-appropriate-mime-type
+                '(application/json text/html)
+                mime-types)
+           ((application/json)
+            (render-json
+             `((versions
+                . ,(list->vector
+                    (map (match-lambda
+                           ((derivation-file-name
+                             first-guix-revision-commit
+                             first-datetime
+                             last-guix-revision-commit
+                             last-datetime
+                             builds)
+                            `((derivation_file_name . ,derivation-file-name)
+                              (first_revision
+                               . ((commit . ,first-guix-revision-commit)
+                                  (datetime . ,first-datetime)))
+                              (last_revision
+                               . ((commit . ,last-guix-revision-commit)
+                                  (datetime . ,last-datetime)))
+                              (builds . ,(list->vector builds)))))
+                         system-test-history))))))
+           (else
+            (render-html
+             #:sxml (view-branch-system-test-history
+                     parsed-query-parameters
+                     repository-id
+                     branch-name
+                     system-test-name
+                     valid-systems
+                     system-test-history)))))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
      (letpar& ((commit-hash
                 (with-thread-postgresql-connection
diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm
index 314f070..88f2632 100644
--- a/guix-data-service/web/repository/html.scm
+++ b/guix-data-service/web/repository/html.scm
@@ -28,6 +28,7 @@
             view-branch-package
             view-branch-package-derivations
             view-branch-package-outputs
+            view-branch-system-test-history
             view-no-latest-revision))
 
 (define* (view-git-repositories git-repositories)
@@ -841,6 +842,179 @@
                versions-list
                outputs-by-revision-range))))))))))
 
+(define (view-branch-system-test-history query-parameters
+                                         git-repository-id
+                                         branch-name
+                                         system-test-name
+                                         valid-systems
+                                         system-test-history)
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container-fluid"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (a (@ (href ,(string-append "/repository/" git-repository-id)))
+           (h3 "Repository"))
+        (a (@ (href ,(string-append "/repository/" git-repository-id
+                                    "/branch/" branch-name)))
+           (h3 ,(string-append branch-name " branch")))
+        (a (@ (class "btn btn-default btn-lg pull-right")
+              (style "margin-left: 0.5em;")
+              (href ,(string-append
+                      "/repository/" git-repository-id
+                      "/branch/" branch-name
+                      "/system-test/" system-test-name
+                      ".json")))
+           "View JSON")
+        (h1 (@ (style "white-space: nowrap;"))
+            (samp ,system-test-name))))
+      (div
+       (@ (class "col-md-12"))
+       (div
+        (@ (class "well"))
+        (form
+         (@ (method "get")
+            (action "")
+            (class "form-horizontal"))
+         ,(form-horizontal-control
+           "System" query-parameters
+           #:options valid-systems
+           #:allow-selecting-multiple-options #f
+           #:help-text "Show derivations with this system.")
+         (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"))))))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (table
+         (@ (class "table")
+            (style "table-layout: fixed;"))
+         (thead
+          (tr
+           (th (@ (class "col-sm-6")) "Derivation")
+           (th (@ (class "col-sm-2")) "From")
+           (th (@ (class "col-sm-2")) "To")
+           (th (@ (class "col-sm-1")) "")
+           (th (@ (class "col-sm-1")) "")))
+         (tbody
+          ,@(let* ((times-in-seconds
+                    (map (lambda (d)
+                           (time-second
+                            (date->time-monotonic
+                             (string->date d "~Y-~m-~d ~H:~M:~S"))))
+                         (append (map third system-test-history)
+                                 (map fifth system-test-history))))
+                   (earliest-date-seconds
+                    (apply min
+                           times-in-seconds))
+                   (latest-date-seconds
+                    (apply max
+                           times-in-seconds))
+                   (min-to-max-seconds
+                    (- latest-date-seconds
+                       earliest-date-seconds)))
+              (map
+               (match-lambda*
+                 (((derivation-file-name
+                    first-guix-revision-commit
+                    first-datetime
+                    last-guix-revision-commit
+                    last-datetime
+                    builds)
+                   next-derivation-file-name)
+                  `((tr
+                     (@ (style "border-bottom: 0;"))
+                     (td
+                      (a (@ (href ,derivation-file-name))
+                         ,(display-store-item derivation-file-name)
+                         ,@(build-statuses->build-status-labels builds)))
+                     (td (a (@ (href ,(string-append
+                                       "/revision/" first-guix-revision-commit))
+                               (title ,(simple-format
+                                        #f
+                                        "~A\n (Revision created at ~A)"
+                                        first-guix-revision-commit
+                                        first-datetime)))
+                            (samp ,(string-take first-guix-revision-commit 8) "…"))
+                         (small (@ (style "display: block;")
+                                   (title
+                                    ,(simple-format #f "Revision created at ~A" first-datetime)))
+                                ,first-datetime))
+                     (td (a (@ (href ,(string-append
+                                       "/revision/" last-guix-revision-commit))
+                               (title ,(simple-format
+                                        #f
+                                        "~A\n (Revision created at ~A)"
+                                        last-guix-revision-commit
+                                        last-datetime)))
+                            (samp ,(string-take last-guix-revision-commit 8) "…"))
+                         (small (@ (style "display: block;")
+                                   (title
+                                    ,(simple-format #f "Revision created at ~A" last-datetime)))
+                                ,last-datetime))
+                     (td
+                      (@ (rowspan 4)
+                         (style "vertical-align: middle;"))
+                      ,@(if next-derivation-file-name
+                            `((a
+                               (@ (class "btn btn-sm btn-default")
+                                  (title "Compare")
+                                  (href
+                                   ,(string-append
+                                     "/compare/derivation"
+                                     "?base_derivation=" next-derivation-file-name
+                                     "&target_derivation=" derivation-file-name)))
+                               "⇕ Compare"))
+                            '())))
+                    (tr
+                     (td
+                      (@ (colspan 4)
+                         (style "border-top: 0; padding-top: 0;"))
+                      (div
+                       (@
+                        (style
+                            ,(let* ((start-seconds
+                                     (time-second
+                                      (date->time-monotonic
+                                       (string->date first-datetime
+                                                     "~Y-~m-~d ~H:~M:~S"))))
+                                    (end-seconds
+                                     (time-second
+                                      (date->time-monotonic
+                                       (string->date last-datetime
+                                                     "~Y-~m-~d ~H:~M:~S"))))
+                                    (margin-left
+                                     (min
+                                      (* (/ (- start-seconds earliest-date-seconds)
+                                            min-to-max-seconds)
+                                         100)
+                                      98))
+                                    (width
+                                     (max
+                                      (- (* (/ (- end-seconds earliest-date-seconds)
+                                               min-to-max-seconds)
+                                            100)
+                                         margin-left)
+                                      2)))
+                               (simple-format
+                                #f
+                                "margin-left: ~A%; width: ~A%; height: 10px; background: #BEBEBE;"
+                                (rationalize margin-left 1)
+                                (rationalize width 1)))))))))))
+               system-test-history
+               (append
+                (map first
+                     (cdr system-test-history))
+                '(#f))))))))))))
+
 (define (view-no-latest-revision branch-name)
   (layout
    #:body