diff options
Diffstat (limited to 'guix-qa-frontpage/view/shared.scm')
| -rw-r--r-- | guix-qa-frontpage/view/shared.scm | 726 |
1 files changed, 564 insertions, 162 deletions
diff --git a/guix-qa-frontpage/view/shared.scm b/guix-qa-frontpage/view/shared.scm index 3411224..3cf92b8 100644 --- a/guix-qa-frontpage/view/shared.scm +++ b/guix-qa-frontpage/view/shared.scm @@ -27,19 +27,177 @@ #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage view util) #:export (package-changes-view - package-changes-summary-table)) + package-cross-changes-view + package-changes-summary-table + package-cross-changes-summary-table)) + +(define (builds->overall-status builds) + (if (eq? #f builds) + 'not-present + (let ((build-statuses + (map + (lambda (build) + (let ((status + (assoc-ref build "status"))) + (if (and (string=? status "scheduled") + (assoc-ref build "potentially_blocked")) + "blocked" + status))) + builds))) + (cond + ((member "succeeded" build-statuses) + 'succeeding) + ((and (not (member "succeeded" build-statuses)) + (member "failed" build-statuses)) + 'failing) + ((member "blocked" build-statuses) + 'blocked) + (else + 'unknown))))) + +(define %changes + '(broken + fixed + blocked + still-working + still-failing + still-blocked + new-working + new-failing + new-blocked + removed-working + removed-failing + removed-blocked + unknown-to-working + unknown-to-failing + unknown-to-blocked + unknown)) + +(define (builds->change-by-system builds-by-system) + (map + (match-lambda + ((system . builds) + (let ((base-status (builds->overall-status + (assoc-ref builds "base"))) + (target-status (builds->overall-status + (assoc-ref builds "target")))) + (cons + system + (cond + ((and (eq? base-status 'succeeding) + (eq? target-status 'failing)) + 'broken) + ((and (eq? base-status 'succeeding) + (eq? target-status 'blocked)) + 'blocked) + ((and (or (eq? base-status 'failing) + (eq? base-status 'blocked)) + (eq? target-status 'succeeding)) + 'fixed) + ((and (eq? 'not-present base-status) + (eq? 'succeeding target-status)) + 'new-working) + ((and (eq? 'not-present base-status) + (eq? 'failing target-status)) + 'new-failing) + ((and (eq? 'not-present base-status) + (eq? 'blocked target-status)) + 'new-blocked) + ((and (eq? 'succeeding base-status) + (eq? 'not-present target-status)) + 'removed-working) + ((and (eq? 'failing base-status) + (eq? 'not-present target-status)) + 'removed-failing) + ((and (eq? 'blocked base-status) + (eq? 'not-present target-status)) + 'removed-blocked) + ((and (eq? base-status target-status 'succeeding)) + 'still-working) + ((and (eq? base-status target-status 'failing)) + 'still-failing) + ((and (eq? base-status target-status 'blocked)) + 'still-blocked) + ((and (or (eq? 'unknown base-status) + (eq? 'blocked base-status)) + (eq? 'succeeding target-status)) + 'unknown-to-working) + ((and (or (eq? 'unknown base-status) + (eq? 'blocked base-status)) + (eq? 'failing target-status)) + 'unknown-to-failing) + ((and (eq? 'unknown base-status) + (eq? 'blocked target-status)) + 'unknown-to-blocked) + (else 'unknown)))))) + builds-by-system)) + +(define (display-builds builds derivations change) + (define %color-for-change + '((fixed . "green") + (broken . "red") + (blocked . "yellow") + (still-working . "lightgreen") + (still-failing . "#FFCCCB") + (still-blocked . "lightyellow") + (new-working . "lightgreen") + (new-failing . "red") + (new-blocked . "lightyellow") + (removed-working . "") + (removed-failing . "") + (removed-blocked . "") + (unknown-to-working . "lightgreen") + (unknown-to-failing . "#FFCCCB") + (unknown-to-blocked . "lightyellow") + (unknown . "lightgrey"))) + + (if builds + (let ((base-status + (builds->overall-status + (assoc-ref builds "base"))) + (target-status + (builds->overall-status + (assoc-ref builds "target")))) + (if (and + (eq? base-status 'not-present) + (eq? target-status 'not-present)) + '(td) + `(td + (@ (style ,(simple-format + #f + "background-color: ~A;" + (assq-ref + %color-for-change + change)))) + ,(if (eq? base-status 'not-present) + `(div "was not present") + `(div + (a (@ (href ,(string-append + "https://data.qa.guix.gnu.org" + (uri-encode-filename + (assoc-ref derivations "base"))))) + "was " ,base-status))) + ,(if (eq? target-status 'not-present) + `(div "now not present") + `(div + (a (@ (href ,(string-append + "https://data.qa.guix.gnu.org" + (uri-encode-filename + (assoc-ref derivations "target"))))) + "now " ,target-status)))))) + '(td))) (define (package-changes-view title derivation-changes query-parameters) - (define (derivation-for-system side system) + (define (derivation-for-system derivations system) (vector-any (lambda (derivation) (if (string=? (assoc-ref derivation "system") system) derivation #f)) - side)) + derivations)) (define (builds-by-system base target) (map @@ -73,162 +231,6 @@ (assoc-ref derivation "derivation-file-name"))))))) %systems-to-submit-builds-for)) - (define (builds->overall-status side-builds) - (if (eq? #f side-builds) - 'not-present - (let ((build-statuses - (map - (lambda (build) - (let ((status - (assoc-ref build "status"))) - (if (and (string=? status "scheduled") - (assoc-ref build "potentially_blocked")) - "blocked" - status))) - side-builds))) - (cond - ((member "succeeded" build-statuses) - 'succeeding) - ((and (not (member "succeeded" build-statuses)) - (member "failed" build-statuses)) - 'failing) - ((member "blocked" build-statuses) - 'blocked) - (else - 'unknown))))) - - (define %changes - '(broken - fixed - blocked - still-working - still-failing - still-blocked - new-working - new-failing - new-blocked - removed-working - removed-failing - removed-blocked - unknown-to-working - unknown-to-failing - unknown-to-blocked - unknown)) - - (define (builds->change-by-system builds-by-system) - (map - (match-lambda - ((system . builds) - (let ((base-status (builds->overall-status - (assoc-ref builds "base"))) - (target-status (builds->overall-status - (assoc-ref builds "target")))) - (cons - system - (cond - ((and (eq? base-status 'succeeding) - (eq? target-status 'failing)) - 'broken) - ((and (eq? base-status 'succeeding) - (eq? target-status 'blocked)) - 'blocked) - ((and (or (eq? base-status 'failing) - (eq? base-status 'blocked)) - (eq? target-status 'succeeding)) - 'fixed) - ((and (eq? 'not-present base-status) - (eq? 'succeeding target-status)) - 'new-working) - ((and (eq? 'not-present base-status) - (eq? 'failing target-status)) - 'new-failing) - ((and (eq? 'not-present base-status) - (eq? 'blocked target-status)) - 'new-blocked) - ((and (eq? 'succeeding base-status) - (eq? 'not-present target-status)) - 'removed-working) - ((and (eq? 'failing base-status) - (eq? 'not-present target-status)) - 'removed-failing) - ((and (eq? 'blocked base-status) - (eq? 'not-present target-status)) - 'removed-blocked) - ((and (eq? base-status target-status 'succeeding)) - 'still-working) - ((and (eq? base-status target-status 'failing)) - 'still-failing) - ((and (eq? base-status target-status 'blocked)) - 'still-blocked) - ((and (or (eq? 'unknown base-status) - (eq? 'blocked base-status)) - (eq? 'succeeding target-status)) - 'unknown-to-working) - ((and (or (eq? 'unknown base-status) - (eq? 'blocked base-status)) - (eq? 'failing target-status)) - 'unknown-to-failing) - ((and (eq? 'unknown base-status) - (eq? 'blocked target-status)) - 'unknown-to-blocked) - (else 'unknown)))))) - builds-by-system)) - - (define (display-builds builds derivations change) - (define %color-for-change - '((fixed . "green") - (broken . "red") - (blocked . "yellow") - (still-working . "lightgreen") - (still-failing . "#FFCCCB") - (still-blocked . "lightyellow") - (new-working . "lightgreen") - (new-failing . "red") - (new-blocked . "lightyellow") - (removed-working . "") - (removed-failing . "") - (removed-blocked . "") - (unknown-to-working . "lightgreen") - (unknown-to-failing . "#FFCCCB") - (unknown-to-blocked . "lightyellow") - (unknown . "lightgrey"))) - - (if builds - (let ((base-status - (builds->overall-status - (assoc-ref builds "base"))) - (target-status - (builds->overall-status - (assoc-ref builds "target")))) - (if (and - (eq? base-status 'not-present) - (eq? target-status 'not-present)) - '(td) - `(td - (@ (style ,(simple-format - #f - "background-color: ~A;" - (assq-ref - %color-for-change - change)))) - ,(if (eq? base-status 'not-present) - `(div "was not present") - `(div - (a (@ (href ,(string-append - "https://data.qa.guix.gnu.org" - (uri-encode-filename - (assoc-ref derivations "base"))))) - "was " ,base-status))) - ,(if (eq? target-status 'not-present) - `(div "now not present") - `(div - (a (@ (href ,(string-append - "https://data.qa.guix.gnu.org" - (uri-encode-filename - (assoc-ref derivations "target"))))) - "now " ,target-status)))))) - '(td))) - (define grouped-query-parameters (group-to-alist identity @@ -365,6 +367,214 @@ '() (assoc-ref derivation-changes "derivation_changes")))))))) +(define (package-cross-changes-view title + system + derivation-changes + query-parameters) + (define (derivation-for-target derivations target) + (vector-any + (lambda (derivation) + (if (string=? (assoc-ref derivation "target") + target) + derivation + #f)) + derivations)) + + ;; TODO This probably performs poorly when there are lots of changes + (define all-targets + (delete-duplicates! + (vector-fold-right + (lambda (_ result package-and-version) + (vector-fold-right + (lambda (_ result derivation) + (let ((target + (assoc-ref derivation "target"))) + (if (string-null? target) + result + (cons target result)))) + (vector-fold-right + (lambda (_ result derivation) + (let ((target + (assoc-ref derivation "target"))) + (if (string-null? target) + result + (cons target result)))) + result + (assoc-ref package-and-version "target")) + (assoc-ref package-and-version "base"))) + '() + (assoc-ref derivation-changes "derivation_changes")))) + + (define (builds-by-target base-data target-data) + (map + (lambda (target) + (cons + target + `(("base" . ,(and=> + (derivation-for-target base-data target) + (lambda (derivation) + (vector->list + (assoc-ref derivation "builds"))))) + ("target" . ,(and=> + (derivation-for-target target-data target) + (lambda (derivation) + (vector->list + (assoc-ref derivation "builds")))))))) + all-targets)) + + (define (derivations-by-target base-data target-data) + (map + (lambda (target) + (cons + target + `(("base" . ,(and=> + (derivation-for-target base-data target) + (lambda (derivation) + (assoc-ref derivation "derivation-file-name")))) + ("target" . ,(and=> + (derivation-for-target target-data target) + (lambda (derivation) + (assoc-ref derivation "derivation-file-name"))))))) + all-targets)) + + (define grouped-query-parameters + (group-to-alist + identity + query-parameters)) + + (define target-change + (map + (lambda (target) + (cons (string-append target "-change") + target)) + all-targets)) + + (define (display? package-and-version change-by-target) + (every + (match-lambda + ((key . vals) + (cond + ((assoc-ref target-change key) + (let ((system (assoc-ref target-change key))) + (->bool + (member (assoc-ref change-by-target system) + (map string->symbol vals))))) + (else #t)))) + grouped-query-parameters)) + + (layout + #:title title + #:body + `((main + (@ (style "max-width: 98%;")) + (table + (form + (@ (id "filter-form") + (method "get")) + (thead + (tr + (td "Name") + (td "Version") + ,@(map + (lambda (target) + `(td (span (@ (style "font-size: 1.5em; font-family: monospace;")) + ,target) + (select + (@ (name + ,(simple-format #f "~A-change" + target)) + (style "margin-bottom: 0;") + (multiple #t)) + ,@(let ((target-change-selected-options + (or (assoc-ref + grouped-query-parameters + (string-append target "-change")) + '()))) + (map + (match-lambda + ((value . label) + `(option + (@ (value ,value) + ,@(if (member (symbol->string value) + target-change-selected-options) + '((selected "")) + '())) + ,label))) + (map + (lambda (change) + (cons change change)) + %changes)))) + (button + (@ (type "submit") + (style "padding: 0; width: 100%;")) + "Update"))) + all-targets)) + (tr + (td) + (td) + ,@(map + (lambda (target) + (let* ((target-change-selected-options + (or (assoc-ref + grouped-query-parameters + (string-append target "-change")) + '())) + (selected-labels + (filter-map + (match-lambda + ((value . label) + (if (member (symbol->string value) + target-change-selected-options) + label + #f))) + (map + (lambda (change) + (cons change change)) + %changes)))) + (if (null? selected-labels) + '(td) + `(td + "Filtering for:" + (ul + (@ (style "margin: 0;")) + ,@(map (lambda (label) + `(li ,label)) + selected-labels)))))) + all-targets)))) + (tbody + (@ (style "overflow: auto; max-height: 40em;")) + ,@(vector-fold-right + (lambda (_ result package-and-version) + (let* ((builds + (builds-by-target + (assoc-ref package-and-version "base") + (assoc-ref package-and-version "target"))) + (derivations + (derivations-by-target + (assoc-ref package-and-version "base") + (assoc-ref package-and-version "target"))) + (change-by-target + ;; This works, even though the naming is wrong as it's + ;; being used to group builds by target + (builds->change-by-system builds))) + (cons + `(tr + (@ ,@(if (display? package-and-version + change-by-target) + '() + '((style "display: none;")))) + (td ,(assoc-ref package-and-version "name")) + (td ,(assoc-ref package-and-version "version")) + ,@(map + (lambda (target) + (display-builds (assoc-ref builds target) + (assoc-ref derivations target) + (assoc-ref change-by-target target))) + all-targets)) + result))) + '() + (assoc-ref derivation-changes "derivation_changes")))))))) + (define (package-changes-summary-table revisions derivation-changes-counts package-changes-url-prefix) @@ -372,10 +582,17 @@ (define* (package-derivations-comparison-link system #:key build-change) (string-append - (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none" + (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A" (assq-ref revisions 'base) - (assq-ref revisions 'target) - system) + (assq-ref revisions 'target)) + (match system + ((system . target) + (simple-format #f "&system=~A&target=~A" + system + target)) + (system + (simple-format #f "&system=~A&target=none" + system))) (if build-change (simple-format #f "&build_change=~A" build-change) ""))) @@ -545,3 +762,188 @@ "target revision."))))))))))) params))) '())))))))) + +(define (package-cross-changes-summary-table revisions + cross-derivation-changes-counts + package-changes-url-prefix) + + (define* (package-derivations-comparison-link system target + #:key build-change) + (string-append + (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A" + (assq-ref revisions 'base) + (assq-ref revisions 'target)) + (simple-format #f "&system=~A&target=~A" + system + target) + (if build-change + (simple-format #f "&build_change=~A" build-change) + ""))) + + `(table + (@ (style "border-collapse: collapse;")) + (thead + (tr + (th (@ (rowspan 3)) "Target") + (th (@ (colspan 8)) "Package build status") + (th)) + (tr + (th (@ (colspan 4)) "Base") + (th (@ (colspan 4) + (style "border-left-width: 0.1em; border-left-style: solid; border-left-color: black")) + "With branch changes") + (th)) + (tr + ,@(let ((header-style + "font-size: 80%; min-width: 3.5rem;")) + `((th (@ (style ,header-style)) + "Succeeding") + (th (@ (style ,header-style)) + "Failing") + (th (@ (style ,header-style)) + "Blocked") + (th (@ (style ,header-style)) + "Unknown") + (th (@ (style + ,(string-append + header-style + " border-left-width: 0.125em; border-left-style: solid; border-left-color: black;"))) + "Succeeding") + (th (@ (style ,header-style)) + "Failing") + (th (@ (style ,header-style)) + "Blocked") + (th (@ (style ,header-style)) + "Unknown") + (th))))) + (tbody + ,@(if (and cross-derivation-changes-counts + (not (assq-ref cross-derivation-changes-counts 'exception))) + (if (null? cross-derivation-changes-counts) + `((tr + (td (@ (colspan 7)) + "No package derivation changes"))) + (map + (match-lambda + (((system . target) . derivations) + + (define (count side status) + (assoc-ref (assoc-ref + derivations + side) + status)) + + `(tr + (td (@ (class "monospace")) ,target) + ,@(map (lambda (status) + `(td ,(count 'base status))) + '(succeeding failing blocked unknown)) + (td ,@(if (and (>= (count 'target 'succeeding) + (count 'base 'succeeding)) + (> (count 'target 'succeeding) + 0)) + `((@ (class "good"))) + '()) + (a (@ (href + ,(string-append + package-changes-url-prefix + "/package-cross-changes?" + target "-change=fixed&" + target "-change=still-working&" + target "-change=unknown-to-working&" + target "-change=new-working"))) + ,(count 'target 'succeeding))) + (td ,@(if (> (count 'target 'failing) + (count 'base 'failing)) + '((@ (class "bad"))) + '()) + (a (@ (href + ,(string-append + package-changes-url-prefix + "/package-cross-changes?" + target "-change=broken&" + target "-change=still-failing&" + target "-change=unknown-to-failing&" + target "-change=new-failing"))) + ,(count 'target 'failing))) + (td ,@(if (> (count 'target 'blocked) + (count 'base 'blocked)) + '((@ (class "bad"))) + '()) + (a (@ (href + ,(string-append + package-changes-url-prefix + "/package-cross-changes?" + target "-change=blocked&" + target "-change=still-blocked&" + target "-change=unknown-to-blocked&" + target "-change=new-blocked"))) + ,(count 'target 'blocked))) + (td (@ ,@(if (> (count 'target 'unknown) + (count 'base 'unknown)) + '((class "bad")) + '())) + (a (@ (href + ,(string-append + package-changes-url-prefix + "/package-cross-changes?" + target "-change=unknown"))) + ,(count 'target 'unknown))) + (td (a (@ (href + ,(package-derivations-comparison-link system + target))) + "View comparison"))))) + cross-derivation-changes-counts)) + `((tr + (td (@ (colspan 10) + (class "bad")) + "Comparison unavailable" + ,@(or (and=> + (assq-ref cross-derivation-changes-counts + 'invalid_query_parameters) + (lambda (params) + (append-map + (match-lambda + ((param . details) + (let ((error + (assq-ref details 'error))) + (cond + ((member param '("base_commit" + "target_commit")) + `((br) + (a + (@ (href + ,(string-append + "https://data.qa.guix.gnu.org" + "/revision/" + (assq-ref + revisions + (if (string=? param "base_commit") + 'base + 'target))))) + ,(cond + ((eq? error 'unknown-commit) + (string-append + (if (string=? param "base_commit") + "Base revision " + "Target revision ") + "unknown to the data service.")) + ((member error + '(yet-to-process-revision + failed-to-process-revision)) + (simple-format + #f "~A to process ~A" + (if (eq? error 'yet-to-process-revision) + "Yet" + "Failed") + (if (string=? param "base_commit") + "base revision (from master branch)" + "target revision"))) + (else + (string-append + "Error with " + (if (string=? param "base_commit") + "base revision." + "target revision."))))))))))) + params))) + '())))))))) |