diff options
author | Christopher Baines <mail@cbaines.net> | 2023-05-23 08:38:41 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2023-05-23 09:21:07 +0100 |
commit | 13994e1916a289bff86a3796f5703606cd205ce4 (patch) | |
tree | 2fb15068bd0b9d1d749d99821e2c2f226b81032b /guix-qa-frontpage | |
parent | e3c999fdbc3209fbc0d9c21a7877d88457f0ca3e (diff) | |
download | qa-frontpage-13994e1916a289bff86a3796f5703606cd205ce4.tar qa-frontpage-13994e1916a289bff86a3796f5703606cd205ce4.tar.gz |
Extract out branch related code
Diffstat (limited to 'guix-qa-frontpage')
-rw-r--r-- | guix-qa-frontpage/branch.scm | 291 | ||||
-rw-r--r-- | guix-qa-frontpage/manage-builds.scm | 1 | ||||
-rw-r--r-- | guix-qa-frontpage/server.scm | 227 |
3 files changed, 294 insertions, 225 deletions
diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm new file mode 100644 index 0000000..60ce2a6 --- /dev/null +++ b/guix-qa-frontpage/branch.scm @@ -0,0 +1,291 @@ +;;; Guix QA Frontpage +;;; +;;; Copyright © 2022, 2023 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-qa-frontpage branch) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module (prometheus) + #:use-module ((guix-build-coordinator utils) + #:select (with-time-logging)) + #:use-module (guix-qa-frontpage git-repository) + #:use-module (guix-qa-frontpage guix-data-service) + #:use-module (guix-qa-frontpage derivation-changes) + #:use-module (guix-qa-frontpage database) + #:use-module (guix-qa-frontpage manage-builds) + #:export (branch-data + master-branch-data + + get-systems-with-low-substitute-availability + + start-refresh-non-patch-branches-data-thread)) + +(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* (get-systems-with-low-substitute-availability substitute-availability + systems + #:key (threshold 0.8)) + (filter-map + (lambda (system-and-target-details) + (let ((system (assoc-ref system-and-target-details "system"))) + (if (and (member system systems) + (string-null? (assoc-ref system-and-target-details "target"))) + (let* ((known + (assoc-ref system-and-target-details "known")) + (unknown + (assoc-ref system-and-target-details "unknown")) + (availability + (/ known + (+ known unknown)))) + (if (< availability threshold) + system + #f)) + #f))) + (vector->list + (assoc-ref (find + (lambda (details) + ;; TODO: Don't hardcode this + (string=? + "https://bordeaux.guix.gnu.org" + (assoc-ref + (assoc-ref details "server") + "url"))) + (vector->list substitute-availability)) + "availability")))) + +(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))))))))) diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm index ec97473..62d98db 100644 --- a/guix-qa-frontpage/manage-builds.scm +++ b/guix-qa-frontpage/manage-builds.scm @@ -8,6 +8,7 @@ #:use-module (guix-build-coordinator utils) #:use-module (guix-build-coordinator client-communication) #:use-module (guix-qa-frontpage database) + #:use-module (guix-qa-frontpage branch) #:use-module (guix-qa-frontpage patchwork) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage guix-data-service) 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))))))))) |