path: root/guix-qa-frontpage/issue.scm

;;; 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 (fibers)
  #:use-module (guix-qa-frontpage utils)
  #: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
            %systems-to-consider-in-issue-status
            status-index

            issue-patches-overall-status

            issue-data
            start-refresh-patch-branches-data-fiber))

(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 waiting-for-build-results-status 'waiting-for-build-results)
(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
        waiting-for-build-results-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 %systems-to-consider-in-issue-status
  '("x86_64-linux"
    "i686-linux"
    "aarch64-linux"
    "armhf-linux"))

(define (issue-patches-overall-status patches-failed-to-apply?
                                      patches-missing?
                                      builds-missing?
                                      derivation-changes
                                      comparison-details
                                      mumi-tags
                                      debbugs-usertags)
  (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))
                     waiting-for-build-results-status)))))
        (filter
         (lambda (builds-by-system)
           (member (car builds-by-system)
                   %systems-to-consider-in-issue-status))
         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-fiber
          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)))

      (for-each
       (match-lambda
         ((issue-number . data)
          (with-sqlite-cache
           database
           'latest-patchwork-series-for-issue
           (const data)
           #:args (list issue-number)
           #:ttl 0)))
       latest-series)

      (non-blocking
       (lambda ()
         (update-repository!)))

      (fibers-batch-for-each
       (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)))
       5
       series-to-refresh)))

  (spawn-fiber
   (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
                 (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)))))))))