;;; Guix QA Frontpage
;;;
;;; Copyright © 2022 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 issue)
#: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 build syscalls)
#:select (set-thread-name))
#: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-data
start-refresh-patch-branches-data-thread))
(define reviewed-looks-good-status 'reviewed-looks-good)
(define good-status 'important-checks-passing)
(define bad-status 'important-checks-failing)
(define needs-looking-at-status 'needs-looking-at)
(define unknown-status 'unknown)
(define large-number-of-builds-status 'large-number-of-builds)
(define failed-to-apply-patches-status 'failed-to-apply-patches)
(define patches-missing-status 'patches-missing)
(define guix-data-service-failed-status 'guix-data-service-failed)
(define %overall-statuses
(list reviewed-looks-good-status
good-status
large-number-of-builds-status
unknown-status
needs-looking-at-status
failed-to-apply-patches-status
patches-missing-status
guix-data-service-failed-status
bad-status))
(define (status-index status)
(list-index (lambda (s)
(eq? s status))
%overall-statuses))
(define (worst-status statuses)
(list-ref %overall-statuses
(apply max (map status-index statuses))))
(define (issue-patches-overall-status patches-failed-to-apply?
patches-missing?
builds-missing?
derivation-changes
comparison-details
mumi-tags
debbugs-usertags)
(define %systems-to-consider
'("x86_64-linux"
;; "i686-linux" disabled while resolving bordeaux build issues
"aarch64-linux"
"armhf-linux"))
(define (guix-data-service-failed?)
(and=>
(assq-ref comparison-details 'exception)
(lambda (exception)
(and=>
(assq-ref comparison-details 'invalid_query_parameters)
(lambda (invalid-params)
(and=>
(assoc-ref invalid-params "target_commit")
(lambda (target-commit)
(eq? (assq-ref target-commit 'error)
'failed-to-process-revision))))))))
(define (builds-status)
(define derivation-changes-counts
(assq-ref derivation-changes 'counts))
(define builds-count
(and
derivation-changes
(length
(derivation-changes->builds-to-keep-and-submit derivation-changes
0))))
(cond
((and builds-count
(> builds-count %patches-builds-limit))
large-number-of-builds-status)
(builds-missing?
unknown-status)
((null? derivation-changes-counts)
good-status)
(else
(worst-status
(map
(match-lambda
((system . counts)
(define (count side status)
(assoc-ref (assoc-ref
counts
side)
status))
(let ((base-failure-count (count 'base 'failing))
(target-failure-count (count 'target 'failing)))
(if (and (<= target-failure-count
base-failure-count)
(= (count 'target 'unknown) 0))
good-status
(if (= (count 'target 'unknown) 0)
(let ((unblocked-builds
(- (count 'base 'blocked)
(count 'target 'blocked)))
(new-failures
(- target-failure-count
base-failure-count)))
(if (>= unblocked-builds
new-failures)
needs-looking-at-status
bad-status))
unknown-status)))))
(filter
(lambda (builds-by-system)
(member (car builds-by-system)
%systems-to-consider))
derivation-changes-counts))))))
(define tags-status
(cond
((member "reviewed-looks-good" debbugs-usertags) reviewed-looks-good-status)
((member "moreinfo" mumi-tags) needs-looking-at-status)
(else good-status)))
;; If it's reviewed and looks good, let this override the other status
;; information
(if (eq? tags-status reviewed-looks-good-status)
reviewed-looks-good-status
(cond
(patches-missing? patches-missing-status)
(patches-failed-to-apply? failed-to-apply-patches-status)
((guix-data-service-failed?) guix-data-service-failed-status)
(else
(worst-status (list (builds-status)
tags-status))))))
(define (issue-data number)
(define (call-with-data-service-error-handling thunk)
(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"))))
`((exception . ,(simple-format #f "~A" exn)))))
thunk
#:unwind? #t))
(let* ((base-and-target-refs
(get-issue-branch-base-and-target-refs
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))))
#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)
#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))))
#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)
#f))
(builds-missing?
(if derivation-changes-data
(builds-missing-for-derivation-changes?
(assoc-ref derivation-changes-raw-data
"derivation_changes"))
#t))
(comparison-details
(and
base-and-target-refs
(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"))))
`((exception . ,(simple-format #f "~A" exn)))))
(lambda ()
(revision-comparison
(revision-comparison-url
base-and-target-refs)))
#:unwind? #t))))
(values
base-and-target-refs
derivation-changes-data
cross-derivation-changes-data
(and=> derivation-changes-raw-data
(lambda (changes)
(alist-delete "derivation_changes" changes)))
builds-missing?
comparison-details)))
(define* (start-refresh-patch-branches-data-thread
database
metrics-registry
#:key number-of-series-to-refresh)
(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)
#:args `(#:count ,number-of-series-to-refresh)))
(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
(match-lambda
((issue-number . series-data)
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"failed updating status for issue ~A: ~A\n"
issue-number
exn)
#f)
(lambda ()
(let ((base-and-target-refs
derivation-changes
cross-derivation-changes
change-details
builds-missing?
comparison-details
(with-sqlite-cache
database
'issue-data
issue-data
#:args
(list issue-number)
#:version 3
#:ttl (/ frequency 2))))
(with-sqlite-cache
database
'issue-patches-overall-status
(lambda _
(let ((patches-failed-to-apply?
(and
(not base-and-target-refs)
(not (eq? (select-create-branch-for-issue-log
database
issue-number)
#f))))
(patches-missing?
(not
(assoc-ref
(assq-ref latest-series issue-number)
"received_all"))))
(issue-patches-overall-status
patches-failed-to-apply?
patches-missing?
builds-missing?
derivation-changes
comparison-details
(assq-ref (assq-ref series-data 'mumi)
'tags)
(assq-ref series-data 'usertags))))
#:args (list issue-number)
#:ttl 0)))
#:unwind? #t)))
series-to-refresh)))
(call-with-new-thread
(lambda ()
(catch 'system-error
(lambda ()
(set-thread-name "data refresh"))
(const #t))
(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
(lambda ()
(call-with-duration-metric
metrics-registry
"refresh_patch_branches_data_duration_seconds"
refresh-data
#:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
(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)))))))))