;;; 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 derivation-changes)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (categorise-packages
            derivation-changes-counts))

(define (categorise-packages derivation-changes side)
  (fold
   (match-lambda*
     ((package result)
      (fold
       ;; builds for specific system and target
       (lambda (details result)
         (let* ((system (assoc-ref details "system"))
                (target (assoc-ref details "target"))
                (build-statuses
                 ;; Invent a new status here "blocked"
                 (map (lambda (build)
                        (let ((status
                               (assoc-ref build "status")))
                          (if (and (string=? status "scheduled")
                                   (assoc-ref build "potentially_blocked"))
                              "blocked"
                              status)))
                      (vector->list
                       (assoc-ref details "builds"))))
                (category
                 (cond
                  ((member "succeeded" build-statuses)
                   'succeeding)
                  ((and (not (member "succeeded" build-statuses))
                        (member "failed" build-statuses))
                   'failing)
                  ((member "blocked" build-statuses)
                   'blocked)
                  (else
                   'unknown))))

           (let* ((system+target
                   (if (string-null? target)
                       system
                       (cons system target)))
                  (categorised-packages
                   (or (assoc-ref result system+target)
                       '())))
             `((,system+target
                .
                ((,category . ,(cons
                                (cons (assoc-ref package "name")
                                      (assoc-ref package "version"))
                                (or (assq-ref categorised-packages category)
                                    '())))
                 ,@(alist-delete category categorised-packages)))
               ,@(alist-delete system+target result)))))
       result
       (vector->list
        (assoc-ref package side)))))
   '()
   derivation-changes))

(define (derivation-changes-counts derivation-changes all-systems)
  (let* ((categorised-base-packages-by-system
          (categorise-packages derivation-changes "base"))
         (categorised-target-packages-by-system
          (categorise-packages derivation-changes "target")))

    (if (null? categorised-target-packages-by-system)
        '()
        (map
         (match-lambda
           ((system . categorised-target-builds)
            (let ((categorised-base-builds
                   (assoc-ref categorised-base-packages-by-system
                              system)))
              (cons
               system
               (map (lambda (side)
                      (cons side
                            (map (lambda (status)
                                   (cons status
                                         (length
                                          (or
                                           (assoc-ref
                                            (if (eq? side 'base)
                                                categorised-base-builds
                                                categorised-target-builds)
                                            status)
                                           '()))))
                                 '(succeeding failing blocked unknown))))
                    '(base target))))))
         (sort
          (append categorised-target-packages-by-system
                  (filter-map
                   (lambda (system)
                     (if (assoc-ref categorised-target-packages-by-system
                                    system)
                         #f
                         (cons system '())))
                   all-systems))
          (lambda (a b)
            (< (or (list-index
                    (lambda (s)
                      (string=? (car a) s))
                    all-systems)
                   10)
               (or (list-index
                    (lambda (s)
                      (string=? (car b) s))
                    all-systems)
                   10))))))))