diff options
Diffstat (limited to 'guix-qa-frontpage/server.scm')
| -rw-r--r-- | guix-qa-frontpage/server.scm | 227 |
1 files changed, 2 insertions, 225 deletions
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index 4aa4ac8..e4e46ee 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -38,6 +38,7 @@ #:use-module (guix-qa-frontpage derivation-changes) #:use-module (guix-qa-frontpage patchwork) #:use-module (guix-qa-frontpage mumi) + #:use-module (guix-qa-frontpage branch) #:use-module (guix-qa-frontpage issue) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage manage-builds) @@ -51,8 +52,7 @@ #:use-module (guix-qa-frontpage view issue) #:export (start-guix-qa-frontpage-web-server - start-refresh-patch-branches-data-thread - start-refresh-non-patch-branches-data-thread)) + start-refresh-patch-branches-data-thread)) (define* (make-controller assets-directory database metrics-registry #:key (patch-issues-to-show 200)) @@ -469,80 +469,6 @@ port. Also, the port used can be changed by passing the --port option.\n" builds-missing? comparison-details))) -(define* (branch-data branch-name) - (let* ((branch-commit - (get-commit - (string-append "origin/" branch-name))) - (merge-base - (get-git-merge-base - (get-commit "origin/master") - branch-commit)) - - (revisions - `((base . ,merge-base) - (target . ,branch-commit))) - - (derivation-changes-counts - (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") - (lambda (reason) - (cons - param - ;; Convert the HTML error messages to something - ;; easier to handle - (cond - ((string-contains reason - "failed to process revision") - 'failed-to-process-revision) - ((string-contains reason - "yet to process revision") - 'yet-to-process-revision) - (else - reason))))))) - (assoc-ref - (guix-data-service-error-response-body exn) - "query_parameters")))) - `((exception . ,(simple-format #f "~A" exn))))) - (lambda () - (let ((derivation-changes-data - change-details - (revision-derivation-changes - (revision-derivation-changes-url - revisions - #:systems %systems-to-submit-builds-for)))) - - (derivation-changes-counts - derivation-changes-data - %systems-to-submit-builds-for))) - #:unwind? #t)) - - (substitute-availability - (package-substitute-availability - (package-substitute-availability-url - branch-commit)))) - - (values - revisions - derivation-changes-counts - substitute-availability))) - -(define* (master-branch-data) - (let* ((substitute-availability - (package-substitute-availability - "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-substitute-availability.json"))) - - (values - substitute-availability))) - (define* (start-refresh-patch-branches-data-thread database #:key @@ -645,152 +571,3 @@ port. Also, the port used can be changed by passing the --port option.\n" "warning: refreshing data is behind\n") (sleep (- frequency time-taken))))))))) - -(define (start-refresh-non-patch-branches-data-thread database - metrics-registry) - (define frequency - (* 30 60)) - - (define branch-substitutes-known - (make-gauge-metric metrics-registry - "branch_substitutes_known" - #:labels '(server branch system target))) - - (define branch-substitutes-unknown - (make-gauge-metric metrics-registry - "branch_substitutes_unknown" - #:labels '(server branch system target))) - - (define (update-branch-substitute-availability-metrics - branch-name - substitute-availability) - (for-each - (lambda (server-details) - (let ((server-url - (assoc-ref - (assoc-ref server-details "server") - "url"))) - - (for-each - (lambda (system-and-target-details) - (let ((label-values - `((server . ,server-url) - (branch . ,branch-name) - (system - . ,(assoc-ref system-and-target-details - "system")) - (target - . ,(assoc-ref system-and-target-details - "target"))))) - - (metric-set branch-substitutes-known - (assoc-ref system-and-target-details - "known") - #:label-values label-values) - (metric-set branch-substitutes-unknown - (assoc-ref system-and-target-details - "unknown") - #:label-values label-values))) - (vector->list - (assoc-ref server-details "availability"))))) - (vector->list - substitute-availability))) - - (define (refresh-data) - (simple-format (current-error-port) - "refreshing non-patch branches data...\n") - (update-repository!) - - (let ((branches - (with-sqlite-cache - database - 'branches - (lambda () - (remove - (lambda (branch) - (or (string=? (assoc-ref branch "name") - "master") - (string-prefix? "version-" - (assoc-ref branch "name")))) - (list-branches - (list-branches-url 2)))) - #:ttl 0))) - - (n-par-for-each - 1 - (lambda (branch) - (let ((branch-name - (assoc-ref branch "name"))) - (simple-format (current-error-port) - "refreshing data for ~A branch\n" - branch-name) - - (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-throw-handler #t - (lambda () - (let ((revisions - derivation-change-counts - substitute-availability - (with-sqlite-cache - database - 'branch-data - branch-data - #:args - (list branch-name) - #:ttl (/ frequency 2)))) - - (update-branch-substitute-availability-metrics - branch-name - substitute-availability))) - (lambda _ - (backtrace)))) - #:unwind? #t)) - #t) - branches)) - - (let ((master-branch-substitute-availability - (with-sqlite-cache - database - 'master-branch-data - master-branch-data - #:ttl 0))) - - (update-branch-substitute-availability-metrics - "master" - master-branch-substitute-availability))) - - (call-with-new-thread - (lambda () - (while #t - (let ((start-time (current-time))) - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception in branch data refresh thread: ~A\n" - exn)) - (lambda () - (with-time-logging "refreshing branch 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 branch data is behind\n") - (sleep - (- frequency time-taken))))))))) |