diff options
| -rw-r--r-- | guix-qa-frontpage/issue.scm | 96 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 228 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/issue.scm | 165 |
3 files changed, 220 insertions, 269 deletions
diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm index 1c5f52d..587a070 100644 --- a/guix-qa-frontpage/issue.scm +++ b/guix-qa-frontpage/issue.scm @@ -46,7 +46,7 @@ (list-ref %overall-statuses (apply max (map status-index statuses)))) -(define (issue-patches-overall-status derivation-changes mumi-tags) +(define (issue-patches-overall-status derivation-changes-counts builds-missing? mumi-tags) (define %systems-to-consider '("x86_64-linux" ;; "i686-linux" disabled while resolving bordeaux build issues @@ -54,65 +54,43 @@ "armhf-linux")) (define builds-status - (let* ((base-builds - (builds-by-system-excluding-cross-builds - derivation-changes "base")) - (target-builds - (builds-by-system-excluding-cross-builds - derivation-changes "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 (builds-missing-for-derivation-changes? derivation-changes) - unknown-status - (if (null? target-builds) - good-status - (worst-status - (map - (match-lambda - ((system . categorised-target-builds) - (let ((categorised-base-builds - (assoc-ref categorised-base-builds-by-system - system))) - (define (count side status) - (length - (assoc-ref - (if (eq? side 'base) - categorised-base-builds - categorised-target-builds) - status))) + (if builds-missing? + unknown-status + (if (null? derivation-changes-counts) + good-status + (worst-status + (map + (match-lambda + ((system . counts) + (define (count side status) + (assoc-ref (assoc-ref + counts + side) + status)) - (let ((base-failure-count (count 'base 'failing)) - (target-failure-count (count 'target 'failing))) - (if (and (<= target-failure-count - base-failure-count) - (= (count 'target 'unknown) 0)) - good-status - (if (= (count 'target 'unknown) 0) - (let ((unblocked-builds - (- (count 'base 'blocked) - (count 'target 'blocked))) - (new-failures - (- target-failure-count - base-failure-count))) - (if (>= unblocked-builds - new-failures) - needs-looking-at-status - bad-status)) - unknown-status)))))) - (filter - (lambda (builds-by-system) - (member (car builds-by-system) - %systems-to-consider)) - categorised-target-builds-by-system))))))) + (let ((base-failure-count (count 'base 'failing)) + (target-failure-count (count 'target 'failing))) + (if (and (<= target-failure-count + base-failure-count) + (= (count 'target 'unknown) 0)) + good-status + (if (= (count 'target 'unknown) 0) + (let ((unblocked-builds + (- (count 'base 'blocked) + (count 'target 'blocked))) + (new-failures + (- target-failure-count + base-failure-count))) + (if (>= unblocked-builds + new-failures) + needs-looking-at-status + bad-status)) + unknown-status))))) + (filter + (lambda (builds-by-system) + (member (car builds-by-system) + %systems-to-consider)) + derivation-changes-counts)))))) (define tags-status (if (member "moreinfo" mumi-tags) diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index f770574..219f3f1 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -317,62 +317,17 @@ (string->number number)))) (if series (let* ((base-and-target-refs + derivation-changes-counts + change-details + builds-missing? + comparison-details (with-sqlite-cache database - 'issue-branch-base-and-target-refs - get-issue-branch-base-and-target-refs - #:args (list (string->number number)) - #:ttl 1200 - #:store-computed-value? list?)) - (derivation-changes-data - change-details - (call-with-values - (lambda () - (and - base-and-target-refs - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception fetching derivation changes: ~A\n" - exn) - - (values #f #f)) - (lambda () - (with-sqlite-cache - database - 'derivation-changes - derivation-changes - #:args - (list - (patch-series-derivation-changes-url - base-and-target-refs - #:systems %systems-to-submit-builds-for)) - #:ttl 6000)) - #:unwind? #t))) - (lambda res - (match res - ((#f) - (values #f #f)) - (_ (apply values res)))))) - (comparison-details - (and - base-and-target-refs - (with-exception-handler - (lambda (exn) - (if (guix-data-service-error? exn) - exn - (raise-exception exn))) - (lambda () - (with-sqlite-cache - database - 'lint-warnings - patch-series-comparison - #:args - (list (patch-series-compare-url - base-and-target-refs)) - #:ttl 6000)) - #:unwind? #t)))) + 'issue-data + issue-data + #:args + (list (string->number number)) + #:ttl 6000))) (render-html #:sxml (issue-view number series @@ -382,7 +337,8 @@ (patch-series-compare-url base-and-target-refs #:json? #f)) - derivation-changes-data + derivation-changes-counts + builds-missing? change-details comparison-details))) (render-html @@ -445,6 +401,67 @@ 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 (issue-data number) + (let* ((base-and-target-refs + (get-issue-branch-base-and-target-refs + number)) + (derivation-changes-data + change-details + (call-with-values + (lambda () + (and + base-and-target-refs + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception fetching derivation changes: ~A\n" + exn) + + (values #f #f)) + (lambda () + (derivation-changes + (patch-series-derivation-changes-url + base-and-target-refs + #:systems %systems-to-submit-builds-for))) + #:unwind? #t))) + (lambda res + (match res + ((#f) + (values #f #f)) + (_ (apply values res)))))) + (derivation-changes-counts + (if derivation-changes-data + (derivation-changes-counts + derivation-changes-data + %systems-to-submit-builds-for) + #f)) + (builds-missing? + (if derivation-changes-data + (builds-missing-for-derivation-changes? + derivation-changes-data) + #t)) + (comparison-details + (and + base-and-target-refs + (with-exception-handler + (lambda (exn) + (if (guix-data-service-error? exn) + exn + (raise-exception exn))) + (lambda () + (patch-series-comparison + (patch-series-compare-url + base-and-target-refs))) + #:unwind? #t)))) + + (values + base-and-target-refs + derivation-changes-counts + change-details + builds-missing? + comparison-details))) + (define* (branch-data branch-name) (let* ((derivation-changes-data change-details @@ -489,60 +506,53 @@ port. Also, the port used can be changed by passing the --port option.\n" (n-par-for-each 4 (lambda (series) - (let ((derivation-changes-data - (with-exception-handler - (lambda (exn) - (unless - (and (guix-data-service-error? exn) - ;; This probably just means the target - ;; revision hasn't been processed yet. The - ;; Guix Data Service should send a more - ;; informative response though. - (and=> (assoc-ref - (guix-data-service-error-response-body exn) - "error") - (lambda (error) - (string=? error - "invalid query")))) - (simple-format - (current-error-port) - "failed fetching derivation changes for issue ~A: ~A\n" - (car series) - exn)) - - #f) - (lambda () - (and=> - (with-sqlite-cache - database - 'issue-branch-base-and-target-refs - get-issue-branch-base-and-target-refs - #:args (list (car series)) - #:ttl 0 - #:store-computed-value? list?) - (lambda (base-and-target-refs) - (with-sqlite-cache - database - 'derivation-changes - derivation-changes - #:args - (list (patch-series-derivation-changes-url - base-and-target-refs - #:systems %systems-to-submit-builds-for)) - #:ttl (/ frequency 2))))) - #:unwind? #t))) - - (and derivation-changes-data - (with-sqlite-cache - database - 'issue-patches-overall-status - (lambda (id) - (issue-patches-overall-status - derivation-changes-data - (assq-ref (assq-ref series 'mumi) - 'tags))) - #:args (list (car series)) - #:ttl 0)))) + (with-exception-handler + (lambda (exn) + (unless + (and (guix-data-service-error? exn) + ;; This probably just means the target + ;; revision hasn't been processed yet. The + ;; Guix Data Service should send a more + ;; informative response though. + (and=> (assoc-ref + (guix-data-service-error-response-body exn) + "error") + (lambda (error) + (string=? error + "invalid query")))) + (simple-format + (current-error-port) + "failed fetching derivation changes for issue ~A: ~A\n" + (car series) + exn)) + + #f) + (lambda () + (let ((base-and-target-refs + derivation-changes-counts + change-details + builds-missing? + comparison-details + (with-sqlite-cache + database + 'issue-data + issue-data + #:args + (list (car series)) + #:ttl 6000))) + + (with-sqlite-cache + database + 'issue-patches-overall-status + (lambda (id) + (issue-patches-overall-status + derivation-changes-counts + builds-missing? + (assq-ref (assq-ref series 'mumi) + 'tags))) + #:args (list (car series)) + #:ttl 0))) + #:unwind? #t)) series-to-refresh))) (call-with-new-thread diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm index 2109f54..186797e 100644 --- a/guix-qa-frontpage/view/issue.scm +++ b/guix-qa-frontpage/view/issue.scm @@ -11,7 +11,8 @@ (define (issue-view issue-number series mumi-tags comparison-link - derivation-changes + derivation-changes-counts + builds-missing? change-details comparison-details) (define* (package-derivations-comparison-link system @@ -235,106 +236,68 @@ td.bad { (tbody ,@(if (and comparison-details (not (guix-data-service-error? comparison-details)) - derivation-changes - (not (builds-missing-for-derivation-changes? - 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")) - - (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 10)) - "No package derivation changes" - (br) - (small "(for the following systems: " - ,@(drop-right - (append-map - (lambda (system) - `((span (@ (style "font-family: monospace;")) - ,system) - ", ")) - %systems-to-submit-builds-for) - 1) - ")")))) - (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 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")) - (a (@ (href ,(package-derivations-comparison-link - system - #:build-change "broken"))) - ,(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")) - (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))))))) + derivation-changes-counts + (not builds-missing?)) + (if (null? derivation-changes-counts) + `((tr + (td (@ (colspan 10)) + "No package derivation changes" + (br) + (small "(for the following systems: " + ,@(drop-right + (append-map + (lambda (system) + `((span (@ (style "font-family: monospace;")) + ,system) + ", ")) + %systems-to-submit-builds-for) + 1) + ")")))) + (map + (match-lambda + ((system . counts) + (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")) + (a (@ (href ,(package-derivations-comparison-link + system + #:build-change "broken"))) + ,(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")) + (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"))))) + derivation-changes-counts)) `((tr (td (@ (colspan 10) (class "bad")) |