[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: Support comparing revision system test derivations
|
From: |
Christopher Baines |
|
Subject: |
03/03: Support comparing revision system test derivations |
|
Date: |
Mon, 4 Jan 2021 14:16:04 -0500 (EST) |
cbaines pushed a commit to branch master
in repository data-service.
commit 6f89066355246a475897a66751afc7a75dd62aa3
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Mon Jan 4 19:15:01 2021 +0000
Support comparing revision system test derivations
This should come in useful for testing patches, as you can see what system
tests are affected, and check the build status.
---
guix-data-service/comparison.scm | 162 +++++++++++++++++
guix-data-service/web/compare/controller.scm | 86 ++++++++-
guix-data-service/web/compare/html.scm | 261 ++++++++++++++++++++++++++-
3 files changed, 505 insertions(+), 4 deletions(-)
diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index 4baed8c..58d0b84 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -44,6 +44,8 @@
lint-warning-differences-data
+ system-test-derivations-differences-data
+
channel-news-differences-data))
(define (derivation-differences-data conn
@@ -963,6 +965,166 @@ ORDER BY coalesce(base_lint_warnings.name,
target_lint_warnings.name) ASC, base_
target-guix-revision-id
locale)))
+(define* (system-test-derivations-differences-data conn
+ base_guix_revision_id
+ target_guix_revision_id
+ system)
+ (define query
+ (string-append "
+WITH base_system_tests AS (
+ SELECT name, description,
+ derivations.file_name AS derivation_file_name,
derivation_output_details_set_id,
+ locations.file, locations.line, locations.column_number
+ FROM guix_revision_system_test_derivations
+ INNER JOIN system_tests
+ ON guix_revision_system_test_derivations.system_test_id = system_tests.id
+ INNER JOIN locations
+ ON system_tests.location_id = locations.id
+ INNER JOIN derivations
+ ON guix_revision_system_test_derivations.derivation_id = derivations.id
+ INNER JOIN derivations_by_output_details_set
+ ON guix_revision_system_test_derivations.derivation_id =
derivations_by_output_details_set.derivation_id
+ WHERE guix_revision_id = $1
+ AND guix_revision_system_test_derivations.system = $3
+), target_system_tests AS (
+ SELECT name, description,
+ derivations.file_name AS derivation_file_name,
derivation_output_details_set_id,
+ locations.file, locations.line, locations.column_number
+ FROM guix_revision_system_test_derivations
+ INNER JOIN system_tests
+ ON guix_revision_system_test_derivations.system_test_id = system_tests.id
+ INNER JOIN locations
+ ON system_tests.location_id = locations.id
+ INNER JOIN derivations
+ ON guix_revision_system_test_derivations.derivation_id = derivations.id
+ INNER JOIN derivations_by_output_details_set
+ ON guix_revision_system_test_derivations.derivation_id =
derivations_by_output_details_set.derivation_id
+ WHERE guix_revision_id = $2
+ AND guix_revision_system_test_derivations.system = $3
+)
+SELECT base_system_tests.name, base_system_tests.description,
base_system_tests.derivation_file_name,
+ base_system_tests.file, base_system_tests.line,
base_system_tests.column_number,
+ (
+ SELECT 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 !=
base_system_tests.derivation_file_name
+ )
+ ORDER BY latest_build_status.timestamp
+ )
+ FROM builds
+ INNER JOIN latest_build_status
+ ON builds.id = latest_build_status.build_id
+ WHERE builds.derivation_output_details_set_id =
+ base_system_tests.derivation_output_details_set_id
+ ) AS base_builds,
+ target_system_tests.name, target_system_tests.description,
target_system_tests.derivation_file_name,
+ target_system_tests.file, target_system_tests.line,
target_system_tests.column_number,
+ (
+ SELECT 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 !=
target_system_tests.derivation_file_name
+ )
+ ORDER BY latest_build_status.timestamp
+ )
+ FROM builds
+ INNER JOIN latest_build_status
+ ON builds.id = latest_build_status.build_id
+ WHERE builds.derivation_output_details_set_id =
+ target_system_tests.derivation_output_details_set_id
+ ) AS target_builds
+FROM base_system_tests
+FULL OUTER JOIN target_system_tests
+ ON base_system_tests.name = target_system_tests.name
+WHERE
+ base_system_tests.name IS NULL OR
+ target_system_tests.name IS NULL OR
+ base_system_tests.derivation_file_name !=
target_system_tests.derivation_file_name
+ORDER BY coalesce(base_system_tests.name, target_system_tests.name) ASC"))
+
+ (map
+ (match-lambda
+ ((base_name base_description base_derivation_file_name
+ base_file base_line base_column_number
+ base_builds
+ target_name target_description target_derivation_file_name
+ target_file target_line target_column_number
+ target_builds)
+ (define (location->alist file line column-number)
+ `((file . ,file)
+ (line . ,(string->number line))
+ (column_number . ,(string->number column-number))))
+
+ (peek base_name base_description base_derivation_file_name
+ base_file base_line base_column_number
+ base_builds
+ target_name target_description target_derivation_file_name
+ target_file target_line target_column_number
+ target_builds)
+ `((name . ,(or base_name target_name))
+ (description . ,(if (and (string? base_description)
+ (string? target_description)
+ (string=? base_description
target_description))
+ base_description
+ `((base . ,(if (null? base_description)
+ 'null
+ base_description))
+ (target . ,(if (null? target_description)
+ 'null
+ target_description)))))
+ (derivation . ,(if (and (string? base_derivation_file_name)
+ (string? target_derivation_file_name)
+ (string=? base_derivation_file_name
+ target_derivation_file_name))
+ base_derivation_file_name
+ `((base . ,base_derivation_file_name)
+ (target . ,target_derivation_file_name))))
+ (location . ,(if
+ (and (string? base_file)
+ (string? target_file)
+ (string=? base_file target_file)
+ (string=? base_line target_line)
+ (string=? base_column_number
target_column_number))
+ (location->alist base_file base_line
base_column_number)
+ `((base . ,(if (null? base_file)
+ 'null
+ (location->alist
+ base_file
+ base_line
+ base_column_number)))
+ (target . ,(if (null? base_file)
+ 'null
+ (location->alist
+ target_file
+ target_line
+ target_column_number))))))
+ (builds . ,(if (and (string? base_derivation_file_name)
+ (string? target_derivation_file_name)
+ (string=? base_derivation_file_name
+ target_derivation_file_name))
+ (json-string->scm base_builds)
+ `((base . ,(if (null? base_builds)
+ #()
+ (json-string->scm base_builds)))
+ (target . ,(if (null? target_builds)
+ #()
+ (json-string->scm
target_builds)))))))))
+ (exec-query-with-null-handling
+ conn
+ query
+ (list base_guix_revision_id
+ target_guix_revision_id
+ system))))
+
(define (channel-news-differences-data conn
base-guix-revision-id
target-guix-revision-id)
diff --git a/guix-data-service/web/compare/controller.scm
b/guix-data-service/web/compare/controller.scm
index 2eea4a1..c5a58f8 100644
--- a/guix-data-service/web/compare/controller.scm
+++ b/guix-data-service/web/compare/controller.scm
@@ -34,6 +34,7 @@
#:use-module (guix-data-service comparison)
#:use-module (guix-data-service jobs load-new-guix-revision)
#:use-module (guix-data-service model guix-revision)
+ #:use-module (guix-data-service model git-repository)
#:use-module (guix-data-service model derivation)
#:use-module (guix-data-service model build-server)
#:use-module (guix-data-service model build-status)
@@ -188,7 +189,17 @@
`((base_commit ,parse-commit #:required)
(target_commit ,parse-commit #:required)))))
(render-compare/packages mime-types
- parsed-query-parameters)))
+ parsed-query-parameters)))
+ (('GET "compare" "system-test-derivations")
+ (let* ((parsed-query-parameters
+ (parse-query-parameters
+ request
+ `((base_commit ,parse-commit #:required)
+ (target_commit ,parse-commit #:required)
+ (system ,parse-system #:default "x86_64-linux")))))
+
+ (render-compare/system-test-derivations mime-types
+ parsed-query-parameters)))
(_ #f)))
(define (texinfo->variants-alist s)
@@ -845,3 +856,76 @@
base-packages-vhash
target-packages-vhash)
#:extra-headers http-headers-for-unchanging-content))))))))
+
+(define (render-compare/system-test-derivations mime-types
+ query-parameters)
+ (if (any-invalid-query-parameters? query-parameters)
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ '((error . "invalid query"))))
+ (else
+ (letpar& ((systems
+ (with-thread-postgresql-connection
+ valid-systems))
+ (build-server-urls
+ (with-thread-postgresql-connection
+ select-build-server-urls-by-id)))
+ (render-html
+ #:sxml (compare/system-test-derivations
+ query-parameters
+ 'revision
+ systems
+ build-server-urls
+ '()
+ '()
+ '())))))
+
+ (let ((base-commit (assq-ref query-parameters 'base_commit))
+ (target-commit (assq-ref query-parameters 'target_commit))
+ (system (assq-ref query-parameters 'system)))
+ (letpar& ((data
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (system-test-derivations-differences-data
+ conn
+ (commit->revision-id conn base-commit)
+ (commit->revision-id conn target-commit)
+ system))))
+ (build-server-urls
+ (with-thread-postgresql-connection
+ select-build-server-urls-by-id))
+ (base-git-repositories
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-repositories-containing-commit conn base-commit))))
+ (target-git-repositories
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-repositories-containing-commit conn
target-commit))))
+ (systems
+ (with-thread-postgresql-connection
+ valid-systems)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((revisions
+ . ((base
+ . ((commit . ,base-commit)))
+ (target
+ . ((commit . ,target-commit)))))
+ (changes . ,(list->vector data)))))
+ (else
+ (render-html
+ #:sxml (compare/system-test-derivations
+ query-parameters
+ 'revision
+ systems
+ build-server-urls
+ base-git-repositories
+ target-git-repositories
+ data))))))))
diff --git a/guix-data-service/web/compare/html.scm
b/guix-data-service/web/compare/html.scm
index 23a63c0..812dc9a 100644
--- a/guix-data-service/web/compare/html.scm
+++ b/guix-data-service/web/compare/html.scm
@@ -23,6 +23,7 @@
#:use-module (texinfo)
#:use-module (texinfo html)
#:use-module (guix-data-service web query-parameters)
+ #:use-module (guix-data-service web util)
#:use-module (guix-data-service web html-utils)
#:use-module (guix-data-service web view html)
#:export (compare
@@ -30,6 +31,7 @@
compare/package-derivations
compare-by-datetime/package-derivations
compare/packages
+ compare/system-test-derivations
compare-invalid-parameters))
(define (compare-form-controls-for-mode mode query-parameters)
@@ -169,7 +171,7 @@
`((div
(@ (class "row") (style "clear: left;"))
(div
- (@ (class "col-sm-6"))
+ (@ (class "col-sm-10"))
(div
(@ (class "btn-group btn-group-lg")
(role "group"))
@@ -190,9 +192,18 @@
((eq? mode 'datetime) "compare-by-datetime"))
"/package-derivations?"
query-params)))
- "Compare package derivations")))
+ "Compare package derivations")
+ (a (@ (class "btn btn-default")
+ (href ,(string-append
+ "/"
+ (cond
+ ((eq? mode 'revision) "compare")
+ ((eq? mode 'datetime) "compare-by-datetime"))
+ "/system-test-derivations?"
+ query-params)))
+ "Compare system test derivations")))
(div
- (@ (class "col-sm-6"))
+ (@ (class "col-sm-2"))
(a (@ (class "btn btn-default btn-lg pull-right")
(href ,(string-append
"/compare.json?" query-params)))
@@ -663,6 +674,17 @@
#:optional
base-revision-details
target-revision-details)
+ (define field-options
+ (map
+ (lambda (field)
+ (cons field
+ (hyphenate-words
+ (string-downcase field))))
+ '("(no additional fields)" "Builds")))
+
+ (define fields
+ (assq-ref query-parameters 'field))
+
(layout
#:body
`(,(header)
@@ -776,6 +798,11 @@ and target derivations")
enough builds to determine a change")))
#:allow-selecting-multiple-options #f)
,(form-horizontal-control
+ "Fields" query-parameters
+ #:name "field"
+ #:options field-options
+ #:help-text "Fields to return in the response.")
+ ,(form-horizontal-control
"After name" query-parameters
#:help-text
"List packages that are alphabetically after the given name.")
@@ -1004,3 +1031,231 @@ enough builds to determine a change")))
(map (lambda (data)
(take data 2))
(vlist->list target-packages-vhash))))))))))))
+
+(define* (compare/system-test-derivations query-parameters
+ mode
+ valid-systems
+ build-server-urls
+ base-git-repositories
+ target-git-repositories
+ changes
+ #:optional
+ base-revision-details
+ target-revision-details)
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container-fluid"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ ,@(cond
+ ((any-invalid-query-parameters? query-parameters)
+ '((h3 "Comparing system test derivations")))
+ ((eq? mode 'revision)
+ (let ((base-commit (assq-ref query-parameters 'base_commit))
+ (target-commit (assq-ref query-parameters 'target_commit)))
+ `((h3
+ (a (@ (href ,(string-append
+ "/compare?base_commit="
+ base-commit
+ "&target_commit="
+ target-commit)))
+ "Comparing "
+ (samp ,(string-take base-commit 8) "…")
+ " and "
+ (samp ,(string-take target-commit 8) "…"))))))
+ ((eq? mode 'datetime)
+ (let ((base-branch (assq-ref query-parameters 'base_branch))
+ (base-datetime (assq-ref query-parameters 'base_datetime))
+ (target-branch (assq-ref query-parameters 'target_branch))
+ (target-datetime (assq-ref query-parameters
'target_datetime)))
+ `((h3
+ (a (@ (href ,(string-append
+ "/compare-by-datetime?"
+ (query-parameters->string
+ (filter (match-lambda
+ ((key . _)
+ (member key '(base_branch
+ base_datetime
+ target_branch
+ target_datetime))))
+ query-parameters)))))
+ "Comparing "
+ (br)
+ (samp (*ENTITY* nbsp) (*ENTITY* nbsp)
+ ,base-branch
+ ,@(map (lambda _ '(*ENTITY* nbsp))
+ (iota (max
+ 0
+ (- (string-length target-branch)
+ (string-length base-branch))))))
+ " at " ,(date->string base-datetime "~1 ~3")
+ " to "
+ (br)
+ (samp (*ENTITY* nbsp) (*ENTITY* nbsp)
+ ,target-branch
+ ,@(map (lambda _ '(*ENTITY* nbsp))
+ (iota (max 0
+ (- (string-length base-branch)
+ (string-length
target-branch))))))
+ " at " ,(date->string target-datetime "~1 ~3")))))))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (div
+ (@ (class "well"))
+ (form
+ (@ (method "get")
+ (action "")
+ (class "form-horizontal"))
+ ,@(compare-form-controls-for-mode mode query-parameters)
+ ,(form-horizontal-control
+ "System" query-parameters
+ #:options valid-systems
+ #:allow-selecting-multiple-options #f
+ #:help-text "Only include derivations for this system."
+ #: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")))
+ (a (@ (class "btn btn-default btn-lg pull-right")
+ (href ,(let ((query-parameter-string
+ (query-parameters->string query-parameters)))
+ (string-append
+ "/"
+ (cond
+ ((eq? mode 'revision) "compare")
+ ((eq? mode 'datetime) "compare-by-datetime"))
+ "/system-test-derivations.json"
+ (if (string-null? query-parameter-string)
+ ""
+ (string-append "?" query-parameter-string))))))
+ "View JSON")))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h1 "System test derivation changes")
+ ,(if
+ (null? changes)
+ '(p "No system test derivation changes")
+ `(table
+ (@ (class "table")
+ (style "table-layout: fixed;"))
+ (thead
+ (tr
+ (th (@ (class "col-sm-2"))
+ "Name")
+ (th (@ (class "col-sm-2"))
+ "Description")
+ (th (@ (class "col-sm-2"))
+ "Location")
+ (th "Derivation")
+ (th (@ (class "col-sm-1"))
+ "")))
+ (tbody
+ ,@(append-map
+ (match-lambda
+ ((('name . name)
+ ('description . description-data)
+ ('derivation . derivation-data)
+ ('location . location-data)
+ ('builds . builds-data))
+
+ (define (render-location git-repositories commit-hash
+ data)
+ (map
+ (match-lambda
+ ((id label url cgit-url-base)
+ (if
+ (and cgit-url-base
+ (not (string-null? cgit-url-base)))
+ (match data
+ ((('file . file)
+ ('line . line)
+ ('column_number . column-number))
+ `(a (@ (href
+ ,(string-append
+ cgit-url-base "tree/"
+ file "?id=" commit-hash
+ "#n" (number->string line))))
+ ,file
+ " (line: " ,line
+ ", column: " ,column-number ")")))
+ '())))
+ git-repositories))
+
+ (define cells
+ (list
+ (if (list? description-data)
+ (cons
+ `(td ,(assq-ref description-data 'base))
+ `(td ,(assq-ref description-data 'target)))
+ (cons
+ `(td (@ (rowspan 2))
+ ,description-data)
+ ""))
+ (if (assq-ref location-data 'base)
+ (cons
+ `(td ,(render-location
+ base-git-repositories
+ (assq-ref query-parameters 'base_commit)
+ (assq-ref location-data 'base)))
+ `(td ,(render-location
+ target-git-repositories
+ (assq-ref query-parameters 'target_commit)
+ (assq-ref location-data 'target))))
+ (cons
+ `(td (@ (rowspan 2))
+ ,(render-location
+ target-git-repositories
+ (assq-ref query-parameters 'target_commit)
+ location-data))
+ ""))
+ (cons
+ (let ((base-derivation (assq-ref derivation-data
'base)))
+ `(td
+ (a (@ (style "display: block;")
+ (href ,base-derivation))
+ (span (@ (class "text-danger glyphicon
glyphicon-minus pull-left")
+ (style "font-size: 1.5em;
padding-right: 0.4em;")))
+ ,@(build-statuses->build-status-labels
+ (vector->list (assq-ref builds-data 'base)))
+ ,(display-store-item-short base-derivation))))
+ (let ((target-derivation (assq-ref derivation-data
'target)))
+ `(td
+ (a (@ (style "display: block;")
+ (href ,target-derivation))
+ (span (@ (class "text-success glyphicon
glyphicon-plus pull-left")
+ (style "font-size: 1.5em;
padding-right: 0.4em;")))
+ ,@(build-statuses->build-status-labels
+ (vector->list (assq-ref builds-data 'target)))
+ ,(display-store-item-short target-derivation)))))
+ (cons
+ `(td (@ (style "vertical-align: middle;")
+ (rowspan 2))
+ (a (@ (class "btn btn-sm btn-default")
+ (title "Compare")
+ (href
+ ,(string-append
+ "/compare/derivation?"
+ "base_derivation="
+ (assq-ref derivation-data 'base)
+ "&target_derivation="
+ (assq-ref derivation-data 'target))))
+ "⇕ Compare"))
+ "")))
+
+ `((tr
+ (td (@ (rowspan 2))
+ ,name)
+ ,@(map car cells))
+ (tr
+ ,@(map cdr cells)))))
+ changes))))))))))