diff options
| -rw-r--r-- | guix-data-service/comparison.scm | 162 | ||||
| -rw-r--r-- | guix-data-service/web/compare/controller.scm | 86 | ||||
| -rw-r--r-- | 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)))))))))) |