diff options
Diffstat (limited to 'guix-qa-frontpage/view/branch.scm')
| -rw-r--r-- | guix-qa-frontpage/view/branch.scm | 239 |
1 files changed, 239 insertions, 0 deletions
diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm new file mode 100644 index 0000000..c68a1b9 --- /dev/null +++ b/guix-qa-frontpage/view/branch.scm @@ -0,0 +1,239 @@ +(define-module (guix-qa-frontpage view branch) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (guix-qa-frontpage manage-builds) + #:use-module (guix-qa-frontpage view util) + #:export (branch-view)) + +(define (branch-view branch derivation-changes) + (define (builds-by-system-excluding-cross-builds side) + (fold (lambda (package result) + (fold + (lambda (change result) + (if (string=? (assoc-ref change "target") + "") + (let ((system (assoc-ref change "system"))) + `((,system + . ,(append + (map + (lambda (build) + `(,@build + ("package" + . (("name" . ,(assoc-ref package "name")) + ("version" . ,(assoc-ref package "version")))))) + (vector->list (assoc-ref change "builds"))) + (or (assoc-ref result system) + '()))) + ,@(alist-delete system result))) + result)) + result + (vector->list + (assoc-ref package side)))) + '() + derivation-changes)) + + (define* (package-derivations-comparison-link system + #:key build-change) + (let ((revisions + (assoc-ref change-details "revisions"))) + (string-append + (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none" + (assoc-ref (assoc-ref revisions "base") + "commit") + (assoc-ref (assoc-ref revisions "target") + "commit") + system) + (if build-change + (simple-format #f "&build_change=~A" build-change) + "")))) + + (define (categorise-builds all-systems builds-by-system) + (define (package-eq? a b) + (and + (string=? + (assoc-ref a "name") + (assoc-ref b "name")) + (string=? + (assoc-ref a "version") + (assoc-ref b "version")))) + + (define (group-builds-by-package builds) + (fold + (lambda (build result) + (let ((package (assoc-ref build "package"))) + `((,package . ,(cons + build + (or + (and=> (find (match-lambda + ((p . _) + (package-eq? p package))) + result) + cdr) + '()))) + ,@(remove + (match-lambda + ((p . _) + (package-eq? p package))) + result)))) + '() + builds)) + + (define systems + (map car builds-by-system)) + + (map + (match-lambda + ((system . builds) + (let ((builds-by-package + (group-builds-by-package builds))) + (cons + system + (fold + (match-lambda* + (((package . builds) result) + (let* ((build-statuses + (map (lambda (build) + (assoc-ref build "status")) + builds)) + (category + (cond + ((member "succeeded" build-statuses) + 'succeeding) + ((and (not (member "suceeded" build-statuses)) + (member "failed" build-statuses)) + 'failing) + (else + 'unknown)))) + + `((,category . ,(cons + (cons package builds) + (assq-ref result category))) + ,@(alist-delete category result))))) + '((succeeding . ()) + (failing . ()) + (unknown . ())) + builds-by-package))))) + + (append builds-by-system + (map (lambda (system) + (cons system '())) + (filter (lambda (system) + (not (member system systems))) + all-systems))))) + + (layout + #:title (simple-format #f "Branch ~A" branch) + #:body + `((main + + + (div + (table + (@ (style "border-collapse: collapse;")) + (thead + (tr + (th (@ (rowspan 3)) "System") + (th (@ (colspan 6)) "Package build status") + (th)) + (tr + (th (@ (colspan 3)) "Base") + (th (@ (colspan 3)) "With patches applied") + (th)) + (tr + (th (@ (style "min-width: 5rem;")) + "Succeeding") + (th (@ (style "min-width: 5rem;")) + "Failing") + (th (@ (style "min-width: 5rem;")) + "Unknown") + (th (@ (style "min-width: 5rem;")) + "Succeeding") + (th (@ (style "min-width: 5rem;")) + "Failing") + (th (@ (style "min-width: 5rem;")) + "Unknown") + (th))) + (tbody + ,@(if derivation-changes + (let* ((base-builds + (builds-by-system-excluding-cross-builds "base")) + (target-builds + (builds-by-system-excluding-cross-builds "target")) + + (all-systems + (delete-duplicates + (append (map car base-builds) + (map car target-builds)))) + + (categorised-base-builds-by-system + (categorise-builds all-systems base-builds)) + (categorised-target-builds-by-system + (categorise-builds all-systems target-builds))) + + (if (null? target-builds) + `((tr + (td (@ (colspan 7)) + "No package derivation changes"))) + (map + (match-lambda + ((system . categorised-target-builds) + (let ((categorised-base-builds + (assoc-ref categorised-base-builds-by-system + system)) + (highlighed-common + " ")) + (define (count side status) + (length + (assoc-ref + (if (eq? side 'base) + categorised-base-builds + categorised-target-builds) + status))) + + `(tr + (td (@ (class "monospace")) ,system) + ,@(map (lambda (status) + `(td ,(count 'base status))) + '(succeeding failing unknown)) + (td ,@(if (and (>= (count 'target 'succeeding) + (count 'base 'succeeding)) + (> (count 'target 'succeeding) + 0)) + `((@ (class "good"))) + '()) + ,(count 'target 'succeeding)) + ,(if (> (count 'target 'failing) + (count 'base 'failing)) + `(td (@ (class "bad")) + (a ;; (@ (href ,(package-derivations-comparison-link + ;; system + ;; #:build-change "broken"))) + ,(count 'target 'failing))) + `(td ,(count 'target 'failing))) + ,(if (> (count 'target 'unknown) + (count 'base 'unknown)) + `(td (@ (class "bad")) + (a ;; (@ (href ,(package-derivations-comparison-link + ;; system + ;; #:build-change "unknown"))) + ,(count 'target 'unknown))) + `(td ,(count 'target 'unknown))) + (td (a ;; (@ (href + ;; ,(package-derivations-comparison-link system))) + "View comparison")))))) + (sort + categorised-target-builds-by-system + (lambda (a b) + (< (or (list-index + (lambda (s) + (string=? (car a) s)) + %systems-to-submit-builds-for) + 10) + (or (list-index + (lambda (s) + (string=? (car b) s)) + %systems-to-submit-builds-for) + 10))))))) + '((tr + (td (@ (colspan 7)) + "Comparison unavailable"))))))))))) |