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

(define (categorise-packages derivation-changes side)
  (define (vector-member? s v)
    (->bool
     (vector-index
      (lambda (e)
        (string=? e s))
      v)))

  (vector-fold
   (lambda (_ result package)
     (vector-fold
      ;; builds for specific system and target
      (lambda (_ result details)
        (let* ((system (assoc-ref details "system"))
               (target (assoc-ref details "target"))
               (build-statuses
                ;; Invent a new status here "blocked"
                (vector-map
                 (lambda (_ build)
                   (let ((status
                          (assoc-ref build "status")))
                     (if (and (string=? status "scheduled")
                              (assoc-ref build "potentially_blocked"))
                         "blocked"
                         status)))
                 (assoc-ref details "builds")))
               (category
                (cond
                 ((vector-member? "succeeded" build-statuses)
                  'succeeding)
                 ((and (not (vector-member? "succeeded" build-statuses))
                       (vector-member? "failed" build-statuses))
                  'failing)
                 ((vector-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
      (assoc-ref package side)))
   '()
   derivation-changes))

(define (derivation-changes derivation-changes all-systems)
  (define categorised-base-packages-by-system
    (categorise-packages (assoc-ref derivation-changes
                                    "derivation_changes")
                         "base"))

  (define categorised-target-packages-by-system
    (categorise-packages (assoc-ref derivation-changes
                                    "derivation_changes")
                         "target"))

  (define counts
    (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)
            (let ((a-key (car a))
                  (b-key (car b)))
              (cond
               ((and (string? a-key)
                     (string? b-key))
                (< (or (list-index
                        (lambda (s)
                          (string=? (car a) s))
                        all-systems)
                       10)
                   (or (list-index
                        (lambda (s)
                          (string=? (car b) s))
                        all-systems)
                       10)))
               ((and (pair? a-key)
                     (pair? b-key))
                (string<? (cdr a-key)
                          (cdr b-key)))
               (else #f))))))))

  `(,@derivation-changes
    (counts  . ,counts)))