diff options
| -rw-r--r-- | guix-qa-frontpage/derivation-changes.scm | 52 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 77 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/branch.scm | 170 |
3 files changed, 167 insertions, 132 deletions
diff --git a/guix-qa-frontpage/derivation-changes.scm b/guix-qa-frontpage/derivation-changes.scm index f339dce..fa286a3 100644 --- a/guix-qa-frontpage/derivation-changes.scm +++ b/guix-qa-frontpage/derivation-changes.scm @@ -20,7 +20,8 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (builds-by-system-excluding-cross-builds - categorise-builds)) + categorise-builds + derivation-changes-counts)) (define (builds-by-system-excluding-cross-builds derivation-changes side) (fold (lambda (package result) @@ -123,3 +124,52 @@ (filter (lambda (system) (not (member system systems))) all-systems))))) + +(define (derivation-changes-counts derivation-changes all-systems) + (let* ((base-builds + (builds-by-system-excluding-cross-builds + derivation-changes "base")) + (target-builds + (builds-by-system-excluding-cross-builds + derivation-changes "target")) + + (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) + '() + (map + (match-lambda + ((system . categorised-target-builds) + (let ((categorised-base-builds + (assoc-ref categorised-base-builds-by-system + system))) + (cons + system + (map (lambda (side) + (cons side + (map (lambda (status) + (cons status + (length + (assoc-ref + (if (eq? side 'base) + categorised-base-builds + categorised-target-builds) + status)))) + '(succeeding failing blocked unknown)))) + '(base target)))))) + (sort + categorised-target-builds-by-system + (lambda (a b) + (< (or (list-index + (lambda (s) + (string=? (car a) s)) + all-systems) + 10) + (or (list-index + (lambda (s) + (string=? (car b) s)) + all-systems) + 10)))))))) diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index 2e25f69..25f550a 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -35,6 +35,7 @@ #:select (with-time-logging get-gc-metrics-updater call-with-delay-logging)) #:use-module (guix-qa-frontpage database) + #:use-module (guix-qa-frontpage derivation-changes) #:use-module (guix-qa-frontpage patchwork) #:use-module (guix-qa-frontpage mumi) #:use-module (guix-qa-frontpage issue) @@ -106,21 +107,20 @@ #:sxml (branches-view branches)))) (('GET "branch" branch) - (let ((derivation-changes - change-details + (let ((change-details + derivation-changes-counts (with-sqlite-cache database - 'branch-derivation-changes - branch-derivation-changes + 'branch-data + branch-data #:args - (list (branch-derivation-changes-url - branch - #:systems %systems-to-submit-builds-for)) + (list branch) #:ttl 6000))) (render-html #:sxml (branch-view branch - derivation-changes)))) + change-details + derivation-changes-counts)))) (('GET "patches") (let* ((latest-series (with-sqlite-cache @@ -445,6 +445,23 @@ Check if it's already running, or whether another process is using that port. Also, the port used can be changed by passing the --port option.\n" port))))))) +(define* (branch-data branch-name) + (let* ((derivation-changes + change-details + (branch-derivation-changes + (branch-derivation-changes-url + branch-name + #:systems %systems-to-submit-builds-for))) + + (derivation-changes-counts + (derivation-changes-counts + derivation-changes + %systems-to-submit-builds-for))) + + (values + change-details + derivation-changes-counts))) + (define* (start-refresh-patch-branches-data-thread database #:key @@ -588,31 +605,25 @@ port. Also, the port used can be changed by passing the --port option.\n" "refreshing data for ~A branch\n" branch-name) - (let ((derivation-changes - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "failed fetching derivation changes for branch ~A: ~A\n" - branch-name - exn) - - #f) - (lambda () - (let ((derivation-changes-url - (branch-derivation-changes-url - branch-name - #:systems %systems-to-submit-builds-for))) - - (with-sqlite-cache - database - 'branch-derivation-changes - branch-derivation-changes - #:args - (list derivation-changes-url) - #:ttl (/ frequency 2)))) - #:unwind? #t))) - #f))) + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "failed fetching derivation changes for branch ~A: ~A\n" + branch-name + exn) + + #f) + (lambda () + (with-sqlite-cache + database + 'branch-data + branch-data + #:args + (list branch-name) + #:ttl (/ frequency 2)))) + #:unwind? #t) + #t) branches))) (call-with-new-thread diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm index 9606564..7589923 100644 --- a/guix-qa-frontpage/view/branch.scm +++ b/guix-qa-frontpage/view/branch.scm @@ -6,7 +6,7 @@ #:use-module (guix-qa-frontpage view util) #:export (branch-view)) -(define (branch-view branch derivation-changes) +(define (branch-view branch change-details derivation-changes-counts) (define* (package-derivations-comparison-link system #:key build-change) (let ((revisions @@ -34,109 +34,83 @@ (thead (tr (th (@ (rowspan 3)) "System") - (th (@ (colspan 6)) "Package build status") + (th (@ (colspan 8)) "Package build status") (th)) (tr - (th (@ (colspan 3)) "Base") - (th (@ (colspan 3)) "With patches applied") + (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 - (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))) + ,@(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 derivation-changes - (let* ((base-builds - (builds-by-system-excluding-cross-builds - derivation-changes "base")) - (target-builds - (builds-by-system-excluding-cross-builds - derivation-changes "target")) + ,@(if derivation-changes-counts + (if (null? derivation-changes-counts) + `((tr + (td (@ (colspan 7)) + "No package derivation changes"))) + (map + (match-lambda + ((system . counts) - (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))))))) + (define (count side status) + (assoc-ref (assoc-ref + counts + side) + status)) + `(tr + (td (@ (class "monospace")) ,system) + ,@(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"))) + '()) + ,(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))) + (td (a (@ (href + ,(package-derivations-comparison-link system))) + "View comparison"))))) + derivation-changes-counts)) '((tr (td (@ (colspan 7)) "Comparison unavailable"))))))))))) |