(define-module (guix-qa-frontpage view branch)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module ((guix-data-service model utils) #:select (group-to-alist))
  #:use-module (guix-qa-frontpage manage-builds)
  #:use-module (guix-qa-frontpage derivation-changes)
  #:use-module (guix-qa-frontpage view util)
  #:export (branch-view
            branch-package-changes-view

            master-branch-view))

(define (branch-view branch revisions derivation-changes
                     substitute-availability
                     up-to-date-with-master
                     master-branch-systems-with-low-substitute-availability)
  (define* (package-derivations-comparison-link system
                                                #:key build-change)
    (string-append
     (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none"
                    (assq-ref revisions 'base)
                    (assq-ref revisions 'target)
                    system)
     (if build-change
         (simple-format #f "&build_change=~A" build-change)
         "")))

  (define derivation-changes-counts
    (assq-ref derivation-changes 'counts))

  (layout
   #:title (simple-format #f "Branch ~A" branch)
   #:head
   '((style "
td.good {
  padding: 0.05rem 0.65rem;
  font-weight: bold;

  border: 0.3rem dashed green;
}

td.bad {
  padding: 0.05rem 0.65rem;
  font-weight: bold;

  border: 0.3rem dashed red;
}"))
   #:body
   `((main
      (div
       (@ (class "large-screen-float-right"))
       (h3 "Links")
       (ul
        (li
         (a (@ (href
                ,(simple-format
                  #f
                  "~A/log/?h=~A&qt=range&q=~A..~A"
                  "https://git.savannah.gnu.org/cgit/guix.git"
                  branch
                  (assq-ref revisions 'base)
                  (assq-ref revisions 'target))))
            "View Git branch"))
        (li
         (a (@ (href ,(simple-format
                       #f "https://data.qa.guix.gnu.org/repository/2/branch/~A"
                       branch)))
            "View branch with Guix Data Service"))))

      ,@(cond
         ((assq-ref up-to-date-with-master 'exception)
          `((p (@ (style ,(string-join
                           '("text-align: center;"
                             "font-weight: bold;"
                             "padding: 1rem;"
                             "max-width: 46rem;"
                             "border-width: 0.35em;"
                             "border-style: dashed;"
                             "border-color: red"))))
               "Exception checking changes between "
               (a (@ (href ,(string-append
                             "https://data.qa.guix.gnu.org/revision/"
                             (assq-ref revisions 'base))))
                  "merge base")
               " and master.")))
         ((assq-ref up-to-date-with-master 'up-to-date?)
          '())
         (else
          `((p (@ (style ,(string-join
                           '("text-align: center;"
                             "font-weight: bold;"
                             "padding: 1rem;"
                             "max-width: 46rem;"
                             "border-width: 0.35em;"
                             "border-style: dashed;"
                             "border-color: red"))))
               "Too many changes ("
               ,(assq-ref up-to-date-with-master 'changes)
               " for "
               (span (@ (style "font-family: monospace;"))
                     "x86_64-linux")
               ") between "
               (a (@ (href ,(string-append
                             "https://data.qa.guix.gnu.org/revision/"
                             (assq-ref revisions 'base))))
                  "merge base")
               " and master, this branch should be rebased or master merged in."))))

      (h2 "Substitute availability")
      (div
       ,@(if substitute-availability
             (map
              (lambda (details)
                `(table
                  (thead
                   (tr
                    (th (@ (colspan 3))
                        ,(assoc-ref
                          (assoc-ref details "server")
                          "url"))))
                  (tbody
                   ,@(map
                      (lambda (system-and-target-details)
                        (let* ((ratio
                                (/ (assoc-ref system-and-target-details
                                              "known")
                                   (+ (assoc-ref system-and-target-details
                                                 "known")
                                      (assoc-ref system-and-target-details
                                                 "unknown"))))
                               (color
                                (cond ((> ratio 0.80) "green")
                                      ((< ratio 0.50) "red")
                                      (else           "orange")))
                               (symbol
                                (cond ((> ratio 0.80)
                                       '(*ENTITY* "#9788"))
                                      ((< ratio 0.50)
                                       '(*ENTITY* "#9729"))
                                      (else
                                       '(*ENTITY* "#9925")))))
                          `(tr
                            (td
                             (@ (style "font-family: monospace;"))
                             ,(assoc-ref system-and-target-details
                                         "system"))
                            (td
                             ,(format #f "~,1f%" (* 100. ratio)))
                            (td (@ (style ,(string-append
                                            "color: black;"
                                            (if color
                                                (simple-format
                                                 #f "background-color: ~A;" color)
                                                ""))))
                                ,symbol))))
                      (filter
                       (lambda (details)
                         (string-null?
                          (assoc-ref details "target")))
                       (vector->list
                        (assoc-ref details "availability")))))))
              (vector->list substitute-availability))
             '("Information unavailable")))

      (h2 "Packages")

      ,@(if (or (null? master-branch-systems-with-low-substitute-availability)
                (not derivation-changes-counts)
                (assq-ref derivation-changes-counts 'exception)
                (null? derivation-changes-counts))
            '()
            `((p (@ (style ,(string-join
                             '("text-align: center;"
                               "font-weight: bold;"
                               "padding: 1rem;"
                               "max-width: 46rem;"
                               "border-width: 0.35em;"
                               "border-style: dashed;"
                               "border-color: red"))))
                 "Submitting builds for this branch suspended as "
                 (a (@ (href "/branch/master"))
                    "master branch substitute availability")
                 " is low for: "
                 ,@(append-map
                    (lambda (system)
                      `((span (@ (style "font-family: monospace; white-space: nowrap;"))
                              ,system
                              " ")))
                    master-branch-systems-with-low-substitute-availability))))

      (div
       (table
        (@ (style "border-collapse: collapse;"))
        (thead
         (tr
          (th (@ (rowspan 3)) "System")
          (th (@ (colspan 8)) "Package build status")
          (th))
         (tr
          (th (@ (colspan 4)) "Base")
          (th (@ (colspan 4)
                 (style "border-left-width: 0.1em; border-left-style: solid; border-left-color: black"))
              "With branch changes")
          (th))
         (tr
          ,@(let ((header-style
                   "font-size: 80%; min-width: 3.5rem;"))
              `((th (@ (style ,header-style))
                    "Succeeding")
                (th (@ (style ,header-style))
                    "Failing")
                (th (@ (style ,header-style))
                    "Blocked")
                (th (@ (style ,header-style))
                    "Unknown")
                (th (@ (style
                           ,(string-append
                             header-style
                             " border-left-width: 0.125em; border-left-style: solid; border-left-color: black;")))
                    "Succeeding")
                (th (@ (style ,header-style))
                    "Failing")
                (th (@ (style ,header-style))
                    "Blocked")
                (th (@ (style ,header-style))
                    "Unknown")
                (th)))))
        (tbody
         ,@(if (and derivation-changes-counts
                    (not (assq-ref derivation-changes-counts 'exception)))
               (if (null? derivation-changes-counts)
                   `((tr
                      (td (@ (colspan 7))
                          "No package derivation changes")))
                   (map
                    (match-lambda
                      ((system . derivations)

                       (define (count side status)
                         (assoc-ref (assoc-ref
                                     derivations
                                     side)
                                    status))
                       `(tr
                         (td (@ (class "monospace")) ,system)
                         ,@(map (lambda (status)
                                  `(td ,(count 'base status)))
                                '(succeeding failing blocked unknown))
                         (td ,@(if (and (>= (count 'target 'succeeding)
                                            (count 'base 'succeeding))
                                        (> (count 'target 'succeeding)
                                           0))
                                   `((@ (class "good")))
                                   '())
                             (a (@ (href
                                    ,(string-append
                                      "/branch/" branch
                                      "/package-changes?"
                                      system "-change=fixed&"
                                      system "-change=still-working&"
                                      system "-change=new-working")))
                                ,(count 'target 'succeeding)))
                         (td ,@(if (> (count 'target 'failing)
                                      (count 'base 'failing))
                                   '((@ (class "bad")))
                                   '())
                             (a (@ (href
                                    ,(string-append
                                      "/branch/" branch
                                      "/package-changes?"
                                      system "-change=broken&"
                                      system "-change=still-failing&"
                                      system "-change=new-failing")))
                                ,(count 'target 'failing)))
                         (td ,@(if (> (count 'target 'blocked)
                                      (count 'base 'blocked))
                                   '((@ (class "bad")))
                                   '())
                             (a (@ (href
                                    ,(string-append
                                      "/branch/" branch
                                      "/package-changes?"
                                      system "-change=blocked&"
                                      system "-change=still-blocked&"
                                      system "-change=new-blocked")))
                                ,(count 'target 'blocked)))
                         (td (@ ,@(if (> (count 'target 'unknown)
                                         (count 'base 'unknown))
                                      '((class "bad"))
                                      '()))
                             (a (@ (href
                                    ,(string-append
                                      "/branch/" branch
                                      "/package-changes?"
                                      system "-change=unknown")))
                                ,(count 'target 'unknown)))
                         (td (a (@ (href
                                    ,(package-derivations-comparison-link system)))
                                "View comparison")))))
                    derivation-changes-counts))
               `((tr
                  (td (@ (colspan 10)
                         (class "bad"))
                      "Comparison unavailable"
                      ,@(or (and=>
                             (assq-ref derivation-changes-counts
                                       'invalid_query_parameters)
                             (lambda (params)
                               (append-map
                                (match-lambda
                                  ((param . details)
                                   (let ((error
                                          (assq-ref details 'error)))
                                     (cond
                                      ((member param '("base_commit"
                                                       "target_commit"))
                                       `((br)
                                         (a
                                          (@ (href
                                              ,(string-append
                                                "https://data.qa.guix.gnu.org"
                                                "/revision/"
                                                (assq-ref
                                                 revisions
                                                 (if (string=? param "base_commit")
                                                     'base
                                                     'target)))))
                                          ,(cond
                                            ((member error
                                                     '(yet-to-process-revision
                                                       failed-to-process-revision))
                                             (simple-format
                                              #f "~A to process ~A"
                                              (if (eq? error 'yet-to-process-revision)
                                                  "Yet"
                                                  "Failed")
                                              (if (string=? param "base_commit")
                                                  "base revision (from master branch)"
                                                  (string-append
                                                   "target revision (from "
                                                   branch " branch)"))))))))))))
                                params)))
                            '()))))))))))))

(define* (delete-duplicates/sort! unsorted-lst less #:key (eq eq?))
  (if (null? unsorted-lst)
      unsorted-lst
      (let ((sorted-lst (sort! unsorted-lst less)))

        (let loop ((lst (cdr sorted-lst))
                   (last-element (car sorted-lst))
                   (result (list (car sorted-lst))))
          (if (null? lst)
              result
              (let ((current-element (car lst)))
                (if (eq current-element last-element)
                    (loop (cdr lst)
                          last-element
                          result)
                    (loop (cdr lst)
                          current-element
                          (cons current-element
                                result)))))))))

(define (branch-package-changes-view branch
                                     revisions
                                     derivation-changes
                                     up-to-date-with-master
                                     query-parameters)
  (define (derivation-for-system side system)
    (vector-any
     (lambda (derivation)
       (if (string=? (assoc-ref derivation "system")
                     system)
           derivation
           #f))
     side))

  (define (builds-by-system base target)
    (map
     (lambda (system)
       (cons
        system
        `(("base" . ,(and=>
                      (derivation-for-system base system)
                      (lambda (derivation)
                        (vector->list
                         (assoc-ref derivation "builds")))))
          ("target" . ,(and=>
                        (derivation-for-system target system)
                        (lambda (derivation)
                          (vector->list
                           (assoc-ref derivation "builds"))))))))
     %systems-to-submit-builds-for))

  (define (derivations-by-system base target)
    (map
     (lambda (system)
       (cons
        system
        `(("base" . ,(and=>
                      (derivation-for-system base system)
                      (lambda (derivation)
                        (assoc-ref derivation "derivation-file-name"))))
          ("target" . ,(and=>
                        (derivation-for-system target system)
                        (lambda (derivation)
                          (assoc-ref derivation "derivation-file-name")))))))
     %systems-to-submit-builds-for))

  (define (builds->overall-status side-builds)
    (if (eq? #f side-builds)
        'not-present
        (let ((build-statuses
               (map
                (lambda (build)
                  (let ((status
                         (assoc-ref build "status")))
                    (if (and (string=? status "scheduled")
                             (assoc-ref build "potentially_blocked"))
                        "blocked"
                        status)))
                side-builds)))
          (cond
           ((member "succeeded" build-statuses)
            'succeeding)
           ((and (not (member "succeeded" build-statuses))
                 (member "failed" build-statuses))
            'failing)
           ((member "blocked" build-statuses)
            'blocked)
           (else
            'unknown)))))

  (define %changes
    '(broken
      fixed
      blocked
      still-working
      still-failing
      still-blocked
      new-working
      new-failing
      new-blocked
      removed-working
      removed-failing
      removed-blocked
      unknown))

  (define (builds->change-by-system builds-by-system)
    (map
     (match-lambda
       ((system . builds)
        (let ((base-status (builds->overall-status
                            (assoc-ref builds "base")))
              (target-status (builds->overall-status
                              (assoc-ref builds "target"))))
          (cons
           system
           (cond
            ((and (eq? base-status 'succeeding)
                  (eq? target-status 'failing))
             'broken)
            ((and (eq? base-status 'succeeding)
                  (eq? target-status 'blocked))
             'blocked)
            ((and (or (eq? base-status 'failing)
                      (eq? base-status 'blocked))
                  (eq? target-status 'succeeding))
             'fixed)
            ((and (eq? 'not-present base-status)
                  (eq? 'succeeding target-status))
             'new-working)
            ((and (eq? 'not-present base-status)
                  (eq? 'failing target-status))
             'new-failing)
            ((and (eq? 'not-present base-status)
                  (eq? 'blocked target-status))
             'new-blocked)
            ((and (eq? 'succeeding base-status)
                  (eq? 'not-present target-status))
             'removed-working)
            ((and (eq? 'failing base-status)
                  (eq? 'not-present target-status))
             'removed-failing)
            ((and (eq? 'blocked base-status)
                  (eq? 'not-present target-status))
             'removed-blocked)
            ((and (eq? base-status target-status 'succeeding))
             'still-working)
            ((and (eq? base-status target-status 'failing))
             'still-failing)
            ((and (eq? base-status target-status 'blocked))
             'still-blocked)
            (else 'unknown))))))
     builds-by-system))

  (define (display-builds builds derivations change)
    (define %color-for-change
      '((fixed           . "green")
        (broken          . "red")
        (blocked         . "yellow")
        (still-working   . "lightgreen")
        (still-failing   . "#FFCCCB")
        (still-blocked   . "lightyellow")
        (new-working     . "lightgreen")
        (new-failing     . "red")
        (new-blocked     . "lightyellow")
        (removed-working . "")
        (removed-failing . "")
        (removed-blocked . "")
        (unknown         . "lightgrey")))

    (if builds
        (let ((base-status
               (builds->overall-status
                (assoc-ref builds "base")))
              (target-status
               (builds->overall-status
                (assoc-ref builds "target"))))
          (if (and
               (eq? base-status 'not-present)
               (eq? target-status 'not-present))
              '(td)
              `(td
                (@ (style ,(simple-format
                            #f
                            "background-color: ~A;"
                            (assq-ref
                             %color-for-change
                             change))))
                ,(if (eq? base-status 'not-present)
                     `(div "was not present")
                     `(div
                       (a (@ (href ,(string-append
                                     "https://data.qa.guix.gnu.org"
                                     (assoc-ref derivations "base"))))
                          "was " ,base-status)))
                ,(if (eq? target-status 'not-present)
                     `(div "now not present")
                     `(div
                       (a (@ (href ,(string-append
                                     "https://data.qa.guix.gnu.org"
                                     (assoc-ref derivations "target"))))
                          "now " ,target-status))))))
        '(td)))

  (define grouped-query-parameters
    (group-to-alist
     identity
     query-parameters))

  (define system-change
    (map
     (lambda (system)
       (cons (string-append system "-change")
             system))
     %systems-to-submit-builds-for))

  (define (display? package-and-version change-by-system)
    (every
     (match-lambda
       ((key . vals)
        (cond
         ((assoc-ref system-change key)
          (let ((system (assoc-ref system-change key)))
            (->bool
             (member (assoc-ref change-by-system system)
                     (map string->symbol vals)))))
         (else #t))))
     grouped-query-parameters))

  (layout
   #:title (simple-format #f "Branch ~A" branch)
   #:body
   `((main
      (table
       (form
        (@ (id "filter-form")
           (method "get"))
        (thead
         (tr
          (td "Name")
          (td "Version")
          ,@(map
             (lambda (system)
               `(td ,system
                    (select
                     (@ (name
                         ,(simple-format #f "~A-change"
                                         system))
                        (multiple #t))
                     ,@(let ((system-change-selected-options
                              (or (assoc-ref
                                   grouped-query-parameters
                                   (string-append system "-change"))
                                  '())))
                         (map
                          (match-lambda
                            ((value . label)
                             `(option
                               (@ (value ,value)
                                  ,@(if (member (symbol->string value)
                                                system-change-selected-options)
                                        '((selected ""))
                                        '()))
                               ,label)))
                          (map
                           (lambda (change)
                             (cons change change))
                           %changes))))
                    (button
                     (@ (type "submit"))
                     "Update")))
             %systems-to-submit-builds-for))))
       (tbody
        (@ (style "overflow: auto; max-height: 40em;"))
        ,@(vector-fold-right
           (lambda (_ result package-and-version)
             (let* ((builds
                     (builds-by-system
                      (assoc-ref package-and-version "base")
                      (assoc-ref package-and-version "target")))
                    (change-by-system
                     (builds->change-by-system builds))
                    (derivations
                     (derivations-by-system
                      (assoc-ref package-and-version "base")
                      (assoc-ref package-and-version "target"))))
               (cons
                `(tr
                  (@ ,@(if (display? package-and-version
                                     change-by-system)
                           '()
                           '((style "display: none;"))))
                  (td ,(assoc-ref package-and-version "name"))
                  (td ,(assoc-ref package-and-version "version"))
                  ,@(map
                     (lambda (system)
                       (display-builds (assoc-ref builds system)
                                       (assoc-ref derivations system)
                                       (assoc-ref change-by-system system)))
                     %systems-to-submit-builds-for))
                result)))
           '()
           (assoc-ref derivation-changes "derivation_changes"))))))))

(define (master-branch-view substitute-availability)
  (layout
   #:title "Branch master"
   #:body
   `((main
      (h2 "Substitute availability")
      (div
       ,@(map
          (lambda (details)
            `(table
              (thead
               (tr
                (th (@ (colspan 3))
                    ,(assoc-ref
                      (assoc-ref details "server")
                      "url"))))
              (tbody
               ,@(map
                  (lambda (system-and-target-details)
                    (let* ((ratio
                            (/ (assoc-ref system-and-target-details
                                          "known")
                               (+ (assoc-ref system-and-target-details
                                             "known")
                                  (assoc-ref system-and-target-details
                                             "unknown"))))
                           (color
                            (cond ((> ratio 0.80) "green")
                                  ((< ratio 0.50) "red")
                                  (else           "orange")))
                           (symbol
                            (cond ((> ratio 0.80)
                                   '(*ENTITY* "#9788"))
                                  ((< ratio 0.50)
                                   '(*ENTITY* "#9729"))
                                  (else
                                   '(*ENTITY* "#9925")))))
                      `(tr
                        (td
                         (@ (style "font-family: monospace;"))
                         ,(assoc-ref system-and-target-details
                                     "system"))
                        (td
                         ,(format #f "~,1f%" (* 100. ratio)))
                        (td (@ (style ,(string-append
                                        "color: black;"
                                        (if color
                                            (simple-format
                                             #f "background-color: ~A;" color)
                                            ""))))
                            ,symbol))))
                  (filter
                   (lambda (details)
                     (string-null?
                      (assoc-ref details "target")))
                   (vector->list
                    (assoc-ref details "availability")))))))
          (vector->list substitute-availability)))))))