diff options
Diffstat (limited to 'guix-qa-frontpage/view/branch.scm')
| -rw-r--r-- | guix-qa-frontpage/view/branch.scm | 373 |
1 files changed, 354 insertions, 19 deletions
diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm index 7847360..830b5cb 100644 --- a/guix-qa-frontpage/view/branch.scm +++ b/guix-qa-frontpage/view/branch.scm @@ -1,15 +1,18 @@ (define-module (guix-qa-frontpage view branch) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module ((guix-data-service model utils) #:select (group-to-alist)) #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage derivation-changes) #:use-module (guix-qa-frontpage view util) #:export (branch-view + branch-package-changes-view master-branch-view)) -(define (branch-view branch revisions derivation-changes-counts +(define (branch-view branch revisions derivation-changes substitute-availability up-to-date-with-master master-branch-systems-with-low-substitute-availability) @@ -24,6 +27,9 @@ (simple-format #f "&build_change=~A" build-change) ""))) + (define derivation-changes-counts + (assq-ref derivation-changes 'counts)) + (layout #:title (simple-format #f "Branch ~A" branch) #:head @@ -230,11 +236,11 @@ td.bad { "No package derivation changes"))) (map (match-lambda - ((system . counts) + ((system . derivations) (define (count side status) (assoc-ref (assoc-ref - counts + derivations side) status)) `(tr @@ -248,22 +254,48 @@ td.bad { 0)) `((@ (class "good"))) '()) - ,(count 'target 'succeeding)) - ,(if (> (count 'target 'failing) - (count 'base 'failing)) - `(td (@ (class "bad")) - ,(count 'target 'failing)) - `(td ,(count 'target 'failing))) - ,(if (> (count 'target 'blocked) - (count 'base 'blocked)) - `(td (@ (class "bad")) - ,(count 'target 'blocked)) - `(td ,(count 'target 'blocked))) - ,(if (> (count 'target 'unknown) - (count 'base 'unknown)) - `(td (@ (class "bad")) - ,(count 'target 'unknown)) - `(td ,(count 'target 'unknown))) + (a (@ (href + ,(string-append + "/branch/" branch + "/package-changes?" + system "-change=fixed&" + system "-change=still-working&" + system "-change=new-working"))) + ,(count 'target 'succeeding))) + (td ,@(if (> (count 'target 'failing) + (count 'base 'failing)) + '((@ (class "bad"))) + '()) + (a (@ (href + ,(string-append + "/branch/" branch + "/package-changes?" + system "-change=broken&" + system "-change=still-failing&" + system "-change=new-failing"))) + ,(count 'target 'failing))) + (td ,@(if (> (count 'target 'blocked) + (count 'base 'blocked)) + '((@ (class "bad"))) + '()) + (a (@ (href + ,(string-append + "/branch/" branch + "/package-changes?" + system "-change=blocked&" + system "-change=still-blocked&" + system "-change=new-blocked"))) + ,(count 'target 'blocked))) + (td (@ ,@(if (> (count 'target 'unknown) + (count 'base 'unknown)) + '((class "bad")) + '())) + (a (@ (href + ,(string-append + "/branch/" branch + "/package-changes?" + system "-change=unknown"))) + ,(count 'target 'unknown))) (td (a (@ (href ,(package-derivations-comparison-link system))) "View comparison"))))) @@ -312,6 +344,309 @@ td.bad { params))) '())))))))))))) +(define* (delete-duplicates/sort! unsorted-lst less #:key (eq eq?)) + (if (null? unsorted-lst) + unsorted-lst + (let ((sorted-lst (sort! unsorted-lst less))) + + (let loop ((lst (cdr sorted-lst)) + (last-element (car sorted-lst)) + (result (list (car sorted-lst)))) + (if (null? lst) + result + (let ((current-element (car lst))) + (if (eq current-element last-element) + (loop (cdr lst) + last-element + result) + (loop (cdr lst) + current-element + (cons current-element + result))))))))) + +(define (branch-package-changes-view branch + revisions + derivation-changes + up-to-date-with-master + query-parameters) + (define (derivation-for-system side system) + (vector-any + (lambda (derivation) + (if (string=? (assoc-ref derivation "system") + system) + derivation + #f)) + side)) + + (define (builds-by-system base target) + (map + (lambda (system) + (cons + system + `(("base" . ,(and=> + (derivation-for-system base system) + (lambda (derivation) + (vector->list + (assoc-ref derivation "builds"))))) + ("target" . ,(and=> + (derivation-for-system target system) + (lambda (derivation) + (vector->list + (assoc-ref derivation "builds")))))))) + %systems-to-submit-builds-for)) + + (define (derivations-by-system base target) + (map + (lambda (system) + (cons + system + `(("base" . ,(and=> + (derivation-for-system base system) + (lambda (derivation) + (assoc-ref derivation "derivation-file-name")))) + ("target" . ,(and=> + (derivation-for-system target system) + (lambda (derivation) + (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)) + + (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) + (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 . "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" + (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" + (assoc-ref derivations "target")))) + "now " ,target-status)))))) + '(td))) + + (define grouped-query-parameters + (group-to-alist + identity + query-parameters)) + + (define system-change + (map + (lambda (system) + (cons (string-append system "-change") + system)) + %systems-to-submit-builds-for)) + + (define (display? package-and-version change-by-system) + (every + (match-lambda + ((key . vals) + (cond + ((assoc-ref system-change key) + (let ((system (assoc-ref system-change key))) + (->bool + (member (assoc-ref change-by-system system) + (map string->symbol vals))))) + (else #t)))) + grouped-query-parameters)) + + (layout + #:title (simple-format #f "Branch ~A" branch) + #:body + `((main + (table + (form + (@ (id "filter-form") + (method "get")) + (thead + (tr + (td "Name") + (td "Version") + ,@(map + (lambda (system) + `(td ,system + (select + (@ (name + ,(simple-format #f "~A-change" + system)) + (multiple #t)) + ,@(let ((system-change-selected-options + (or (assoc-ref + grouped-query-parameters + (string-append system "-change")) + '()))) + (map + (match-lambda + ((value . label) + `(option + (@ (value ,value) + ,@(if (member (symbol->string value) + system-change-selected-options) + '((selected "")) + '())) + ,label))) + (map + (lambda (change) + (cons change change)) + %changes)))) + (button + (@ (type "submit")) + "Update"))) + %systems-to-submit-builds-for)))) + (tbody + (@ (style "overflow: auto; max-height: 40em;")) + ,@(vector-fold-right + (lambda (_ result package-and-version) + (let* ((builds + (builds-by-system + (assoc-ref package-and-version "base") + (assoc-ref package-and-version "target"))) + (change-by-system + (builds->change-by-system builds)) + (derivations + (derivations-by-system + (assoc-ref package-and-version "base") + (assoc-ref package-and-version "target")))) + (cons + `(tr + (@ ,@(if (display? package-and-version + change-by-system) + '() + '((style "display: none;")))) + (td ,(assoc-ref package-and-version "name")) + (td ,(assoc-ref package-and-version "version")) + ,@(map + (lambda (system) + (display-builds (assoc-ref builds system) + (assoc-ref derivations system) + (assoc-ref change-by-system system))) + %systems-to-submit-builds-for)) + result))) + '() + (assoc-ref derivation-changes "derivation_changes")))))))) + (define (master-branch-view substitute-availability) (layout #:title "Branch master" |