diff options
Diffstat (limited to 'guix-qa-frontpage/issue.scm')
| -rw-r--r-- | guix-qa-frontpage/issue.scm | 158 |
1 files changed, 86 insertions, 72 deletions
diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm index 6ceb733..beed41f 100644 --- a/guix-qa-frontpage/issue.scm +++ b/guix-qa-frontpage/issue.scm @@ -23,9 +23,13 @@ #:use-module (ice-9 threads) #:use-module (prometheus) #:use-module ((guix-build-coordinator utils) - #:select (with-time-logging)) + #:select (with-time-logging call-with-delay-logging)) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:use-module (fibers) + #:use-module (knots non-blocking) + #:use-module (knots parallelism) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage manage-patch-branches) @@ -40,7 +44,7 @@ issue-patches-overall-status issue-data - start-refresh-patch-branches-data-thread)) + start-refresh-patch-branches-data-fiber)) (define reviewed-looks-good-status 'reviewed-looks-good) (define good-status 'important-checks-passing) @@ -177,79 +181,73 @@ (with-exception-handler (lambda (exn) (if (guix-data-service-error? exn) - `((exception . guix-data-service-invalid-parameters) - (invalid_query_parameters - . - ,(filter-map - (match-lambda - ((param . val) - (and=> - (assoc-ref val "invalid_value") - (lambda (value) - (let ((message - (assoc-ref val "message"))) - (cons - param - `((value . ,value) - (error - ;; Convert the HTML error messages - ;; to something easier to handle - . ,(cond - ((string-contains message - "failed to process revision") - 'failed-to-process-revision) - ((string-contains message - "yet to process revision") - 'yet-to-process-revision) - (else - 'unknown)))))))))) - (assoc-ref - (guix-data-service-error-response-body exn) - "query_parameters")))) + (guix-data-service-error->sexp exn) `((exception . ,(simple-format #f "~A" exn))))) thunk #:unwind? #t)) (let* ((base-and-target-refs - (get-issue-branch-base-and-target-refs - number)) + (call-with-delay-logging + get-issue-branch-base-and-target-refs + #:args (list number))) (derivation-changes-raw-data (if base-and-target-refs (call-with-data-service-error-handling (lambda () - (compare-package-derivations - (compare-package-derivations-url - base-and-target-refs - #:systems %systems-to-submit-builds-for)))) + (call-with-delay-logging + compare-package-derivations + #:args + (list + (compare-package-derivations-url + base-and-target-refs + #:systems %systems-to-submit-builds-for))))) #f)) (derivation-changes-data (if (and derivation-changes-raw-data (not (assq-ref derivation-changes-raw-data 'exception))) - (derivation-changes - derivation-changes-raw-data - %systems-to-submit-builds-for) + (cons + (cons 'counts + (call-with-delay-logging + derivation-changes-counts + #:args + (list + derivation-changes-raw-data + %systems-to-submit-builds-for))) + derivation-changes-raw-data) #f)) (cross-derivation-changes-raw-data (if base-and-target-refs (call-with-data-service-error-handling (lambda () - (compare-package-derivations - (compare-package-cross-derivations-url - base-and-target-refs - #:systems %systems-to-submit-builds-for)))) + (call-with-delay-logging + compare-package-derivations + #:args + (list + (compare-package-cross-derivations-url + base-and-target-refs + #:systems %systems-to-submit-builds-for))))) #f)) (cross-derivation-changes-data (if (and cross-derivation-changes-raw-data (not (assq-ref cross-derivation-changes-raw-data 'exception))) - (derivation-changes - cross-derivation-changes-raw-data - %systems-to-submit-builds-for) + (cons + (cons 'counts + (call-with-delay-logging + derivation-changes-counts + #:args + (list + cross-derivation-changes-raw-data + %systems-to-submit-builds-for))) + cross-derivation-changes-raw-data) #f)) (builds-missing? (if derivation-changes-data - (builds-missing-for-derivation-changes? - (assoc-ref derivation-changes-raw-data - "derivation_changes")) + (call-with-delay-logging + builds-missing-for-derivation-changes? + #:args + (list + (assoc-ref derivation-changes-raw-data + "derivation_changes"))) #t)) (comparison-details (and @@ -288,9 +286,11 @@ "query_parameters")))) `((exception . ,(simple-format #f "~A" exn))))) (lambda () - (revision-comparison - (revision-comparison-url - base-and-target-refs))) + (call-with-delay-logging + revision-comparison + #:args (list + (revision-comparison-url + base-and-target-refs)))) #:unwind? #t)))) (values @@ -303,12 +303,25 @@ builds-missing? comparison-details))) -(define* (start-refresh-patch-branches-data-thread +(define* (start-refresh-patch-branches-data-fiber database metrics-registry #:key number-of-series-to-refresh) (define frequency - (* 15 60)) + (* 30 60)) + + (define issue-data/fiberized+cached + (fiberize + (lambda (issue-number) + (with-sqlite-cache + database + 'issue-data + issue-data + #:args + (list issue-number) + #:version 3 + #:ttl (/ frequency 2))) + #:parallelism 2)) (define (refresh-data) (simple-format (current-error-port) @@ -326,10 +339,22 @@ (take latest-series number-of-series-to-refresh) latest-series))) - (update-repository!) + (for-each + (match-lambda + ((issue-number . data) + (with-sqlite-cache + database + 'latest-patchwork-series-for-issue + (const data) + #:args (list issue-number) + #:ttl 0))) + latest-series) - (n-par-for-each - 5 + (non-blocking + (lambda () + (update-repository!))) + + (fibers-batch-for-each (match-lambda ((issue-number . series-data) (with-exception-handler @@ -348,14 +373,7 @@ change-details builds-missing? comparison-details - (with-sqlite-cache - database - 'issue-data - issue-data - #:args - (list issue-number) - #:version 3 - #:ttl (/ frequency 2)))) + (issue-data/fiberized+cached issue-number))) (with-sqlite-cache database @@ -385,15 +403,11 @@ #:args (list issue-number) #:ttl 0))) #:unwind? #t))) + 50 series-to-refresh))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "data refresh")) - (const #t)) - (while #t (let ((start-time (current-time))) (with-exception-handler |