;;; 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 (ice-9 match)
  #:use-module (guix-qa-frontpage manage-builds)
  #:use-module (guix-qa-frontpage derivation-changes)
  #:export (%overall-statuses
            status-index

            issue-patches-overall-status))

(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 mumi-tags)
  (define %systems-to-consider
    '("x86_64-linux"
      ;; "i686-linux" disabled while resolving bordeaux build issues
      "aarch64-linux"
      "armhf-linux"))

  (define builds-status
    (let* ((base-builds
            (builds-by-system-excluding-cross-builds
             derivation-changes "base"))
           (target-builds
            (builds-by-system-excluding-cross-builds
             derivation-changes "target"))

           (all-systems
            (delete-duplicates
             (append (map car base-builds)
                     (map car target-builds))))

           (categorised-base-builds-by-system
            (categorise-builds all-systems base-builds))
           (categorised-target-builds-by-system
            (categorise-builds all-systems target-builds)))

      (if (builds-missing-for-derivation-changes? derivation-changes)
          unknown-status
          (if (null? target-builds)
              good-status
              (worst-status
               (map
                (match-lambda
                  ((system . categorised-target-builds)
                   (let ((categorised-base-builds
                          (assoc-ref categorised-base-builds-by-system
                                     system)))
                     (define (count side status)
                       (length
                        (assoc-ref
                         (if (eq? side 'base)
                             categorised-base-builds
                             categorised-target-builds)
                         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))
                 categorised-target-builds-by-system)))))))

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