[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: Add page for looking at the history of a system test
|
From: |
Christopher Baines |
|
Subject: |
02/02: Add page for looking at the history of a system test |
|
Date: |
Sun, 14 Mar 2021 13:53:01 -0400 (EDT) |
cbaines pushed a commit to branch master
in repository data-service.
commit fbaa37328cdc62e39a7cc39e27f8e35bf1bee054
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sun Mar 14 17:52:31 2021 +0000
Add page for looking at the history of a system test
This should be useful for looking at when system tests break.
---
guix-data-service/model/system-test.scm | 103 +++++++++++++-
guix-data-service/web/repository/controller.scm | 51 +++++++
guix-data-service/web/repository/html.scm | 174 ++++++++++++++++++++++++
3 files changed, 327 insertions(+), 1 deletion(-)
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