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

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