(define-module (guix-qa-frontpage view branch)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (guix-qa-frontpage manage-builds)
  #:use-module (guix-qa-frontpage derivation-changes)
  #:use-module (guix-qa-frontpage view util)
  #:export (branch-view

            master-branch-view))

(define (branch-view branch revisions derivation-changes-counts
                     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)
         "")))

  (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
      (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")
      (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 . counts)

                       (define (count side status)
                         (assoc-ref (assoc-ref
                                     counts
                                     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")))
                                   '())
                             ,(count 'target 'succeeding))
                         ,(if (> (count 'target 'failing)
                                 (count 'base 'failing))
                              `(td (@ (class "bad"))
                                   ,(count 'target 'failing))
                              `(td ,(count 'target 'failing)))
                         ,(if (> (count 'target 'blocked)
                                 (count 'base 'blocked))
                              `(td (@ (class "bad"))
                                   ,(count 'target 'blocked))
                              `(td ,(count 'target 'blocked)))
                         ,(if (> (count 'target 'unknown)
                                 (count 'base 'unknown))
                              `(td (@ (class "bad"))
                                   ,(count 'target 'unknown))
                              `(td ,(count 'target 'unknown)))
                         (td (a (@ (href
                                    ,(package-derivations-comparison-link system)))
                                "View comparison")))))
                    derivation-changes-counts))
               `((tr
                  (td (@ (colspan 10))
                      "Comparison unavailable"
                      ,@(or (and=>
                             (assq-ref derivation-changes-counts
                                       'invalid_query_parameters)
                             (lambda (params)
                               (append-map
                                (match-lambda
                                  ((param . 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 (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)))))))