;;; Guix QA Frontpage ;;; ;;; Copyright © 2022 Christopher Baines ;;; ;;; 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 ;;; . (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 ((guix-build-coordinator utils) #:select (with-time-logging)) #: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 good-status 'important-checks-passing) (define bad-status 'important-checks-failing) (define needs-looking-at-status 'needs-looking-at) (define unknown-status 'unknown) (define %overall-statuses (list good-status unknown-status needs-looking-at-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 derivation-changes-counts builds-missing? mumi-tags) (define %systems-to-consider '("x86_64-linux" ;; "i686-linux" disabled while resolving bordeaux build issues "aarch64-linux" "armhf-linux")) (define builds-status (if builds-missing? unknown-status (if (null? derivation-changes-counts) good-status (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 (if (member "moreinfo" mumi-tags) needs-looking-at-status good-status)) (let ((overall-status (worst-status (list builds-status tags-status)))) overall-status)) (define (issue-data number) (let* ((base-and-target-refs (get-issue-branch-base-and-target-refs number)) (derivation-changes-data (if 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 () (compare-package-derivations (compare-package-derivations-url base-and-target-refs #:systems %systems-to-submit-builds-for))) #:unwind? #t) #f)) (derivation-changes (if (and derivation-changes-data (not (assq-ref derivation-changes-data 'exception))) (derivation-changes derivation-changes-data %systems-to-submit-builds-for) #f)) (builds-missing? (if derivation-changes (builds-missing-for-derivation-changes? (assoc-ref derivation-changes-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 (and=> derivation-changes-data (lambda (changes) (alist-delete "derivation_changes" changes))) builds-missing? comparison-details))) (define* (start-refresh-patch-branches-data-thread database #:key (number-of-series-to-refresh 250)) (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))) (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 (lambda (series) (with-exception-handler (lambda (exn) (simple-format (current-error-port) "failed fetching derivation changes for issue ~A: ~A\n" (car series) exn) #f) (lambda () (let ((base-and-target-refs derivation-changes change-details builds-missing? comparison-details (with-sqlite-cache database 'issue-data issue-data #:args (list (car series)) #:version 2 #:ttl (/ frequency 2)))) (with-sqlite-cache database 'issue-patches-overall-status (lambda (id) (issue-patches-overall-status (assq-ref derivation-changes 'counts) builds-missing? (assq-ref (assq-ref series 'mumi) 'tags))) #:args (list (car series)) #:ttl 0))) #:unwind? #t)) series-to-refresh))) (call-with-new-thread (lambda () (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 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 data is behind\n") (sleep (- frequency time-taken)))))))))