aboutsummaryrefslogtreecommitdiff
path: root/guix-qa-frontpage
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2023-05-23 08:38:41 +0100
committerChristopher Baines <mail@cbaines.net>2023-05-23 09:21:07 +0100
commit13994e1916a289bff86a3796f5703606cd205ce4 (patch)
tree2fb15068bd0b9d1d749d99821e2c2f226b81032b /guix-qa-frontpage
parente3c999fdbc3209fbc0d9c21a7877d88457f0ca3e (diff)
downloadqa-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.scm291
-rw-r--r--guix-qa-frontpage/manage-builds.scm1
-rw-r--r--guix-qa-frontpage/server.scm227
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)))))))))