diff options
| -rw-r--r-- | guix-qa-frontpage/issue.scm | 173 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 163 | ||||
| -rw-r--r-- | scripts/guix-qa-frontpage.in | 1 |
3 files changed, 174 insertions, 163 deletions
diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm index 587a070..f7d3d2a 100644 --- a/guix-qa-frontpage/issue.scm +++ b/guix-qa-frontpage/issue.scm @@ -18,13 +18,25 @@ (define-module (guix-qa-frontpage issue) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module ((guix-build-coordinator utils) + #:select (with-time-logging)) + #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage manage-builds) + #:use-module (guix-qa-frontpage manage-patch-branches) + #:use-module (guix-qa-frontpage patchwork) + #:use-module (guix-qa-frontpage git-repository) + #:use-module (guix-qa-frontpage guix-data-service) #:use-module (guix-qa-frontpage derivation-changes) #:export (%overall-statuses status-index - issue-patches-overall-status)) + issue-patches-overall-status + + issue-data + start-refresh-patch-branches-data-thread)) (define good-status 'important-checks-passing) (define bad-status 'important-checks-failing) @@ -101,3 +113,162 @@ (worst-status (list builds-status tags-status)))) overall-status)) + +(define (issue-data number) + (let* ((base-and-target-refs + (get-issue-branch-base-and-target-refs + number)) + (derivation-changes-data + change-details + (if 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 () + (revision-derivation-changes + (revision-derivation-changes-url + base-and-target-refs + #:systems %systems-to-submit-builds-for))) + #:unwind? #t) + (values #f #f))) + (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) + ;; TODO Return some description this error that can be + ;; cached + #f + (raise-exception exn))) + (lambda () + (revision-comparison + (revision-comparison-url + base-and-target-refs))) + #:unwind? #t)))) + + (values + base-and-target-refs + derivation-changes-counts + change-details + builds-missing? + comparison-details))) + +(define* (start-refresh-patch-branches-data-thread + database + #:key + (number-of-series-to-refresh 250)) + (define frequency + (* 15 60)) + + (define (refresh-data) + (simple-format (current-error-port) + "refreshing patch branches data...\n") + (let* ((latest-series + (with-sqlite-cache + database + 'latest-patchwork-series-by-issue + latest-patchwork-series-by-issue + #:ttl (/ frequency 2))) + (series-to-refresh + (if (> (length latest-series) + number-of-series-to-refresh) + (take latest-series number-of-series-to-refresh) + latest-series))) + + (update-repository!) + + (n-par-for-each + 5 + (lambda (series) + (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 (/ frequency 2)))) + + (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 + (lambda () + (while #t + (let ((start-time (current-time))) + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception in data refresh thread: ~A\n" + exn)) + (lambda () + (with-time-logging "refreshing data" + (with-throw-handler #t + refresh-data + (lambda args + (display (backtrace) (current-error-port)) + (newline (current-error-port)))))) + #:unwind? #t) + + (let ((time-taken + (- (current-time) start-time))) + (if (>= time-taken frequency) + (simple-format (current-error-port) + "warning: refreshing data is behind\n") + (sleep + (- frequency time-taken))))))))) diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index 9678c1f..82b8a43 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -50,9 +50,7 @@ #:use-module (guix-qa-frontpage view branches) #:use-module (guix-qa-frontpage view branch) #:use-module (guix-qa-frontpage view issue) - #:export (start-guix-qa-frontpage-web-server - - start-refresh-patch-branches-data-thread)) + #:export (start-guix-qa-frontpage-web-server)) (define (branch-for-issue database issue-number) (let ((branches @@ -472,162 +470,3 @@ error: guix-data-service could not start, as it could not bind to port ~A 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 - (if 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 () - (revision-derivation-changes - (revision-derivation-changes-url - base-and-target-refs - #:systems %systems-to-submit-builds-for))) - #:unwind? #t) - (values #f #f))) - (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) - ;; TODO Return some description this error that can be - ;; cached - #f - (raise-exception exn))) - (lambda () - (revision-comparison - (revision-comparison-url - base-and-target-refs))) - #:unwind? #t)))) - - (values - base-and-target-refs - derivation-changes-counts - change-details - builds-missing? - comparison-details))) - -(define* (start-refresh-patch-branches-data-thread - database - #:key - (number-of-series-to-refresh 250)) - (define frequency - (* 15 60)) - - (define (refresh-data) - (simple-format (current-error-port) - "refreshing patch branches data...\n") - (let* ((latest-series - (with-sqlite-cache - database - 'latest-patchwork-series-by-issue - latest-patchwork-series-by-issue - #:ttl (/ frequency 2))) - (series-to-refresh - (if (> (length latest-series) - number-of-series-to-refresh) - (take latest-series number-of-series-to-refresh) - latest-series))) - - (update-repository!) - - (n-par-for-each - 5 - (lambda (series) - (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 (/ frequency 2)))) - - (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 - (lambda () - (while #t - (let ((start-time (current-time))) - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception in data refresh thread: ~A\n" - exn)) - (lambda () - (with-time-logging "refreshing data" - (with-throw-handler #t - refresh-data - (lambda args - (display (backtrace) (current-error-port)) - (newline (current-error-port)))))) - #:unwind? #t) - - (let ((time-taken - (- (current-time) start-time))) - (if (>= time-taken frequency) - (simple-format (current-error-port) - "warning: refreshing data is behind\n") - (sleep - (- frequency time-taken))))))))) diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in index 72d8dd6..45e63de 100644 --- a/scripts/guix-qa-frontpage.in +++ b/scripts/guix-qa-frontpage.in @@ -33,6 +33,7 @@ (guix pki) (prometheus) (guix-qa-frontpage database) + (guix-qa-frontpage issue) (guix-qa-frontpage branch) (guix-qa-frontpage manage-builds) (guix-qa-frontpage git-repository) |