Show more information about branches, including substitute availability

2 files changed, 128 insertions, 14 deletions

diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm
index 7589923..1429343 100644
--- a/guix-qa-frontpage/view/branch.scm
+++ b/guix-qa-frontpage/view/branch.scm
@@ -1,12 +1,16 @@
 (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))
+  #:export (branch-view
 
-(define (branch-view branch change-details derivation-changes-counts)
+            master-branch-view))
+
+(define (branch-view branch change-details derivation-changes-counts
+                     substitute-availability)
   (define* (package-derivations-comparison-link system
                                                 #:key build-change)
     (let ((revisions
@@ -26,8 +30,57 @@
    #:title (simple-format #f "Branch ~A" branch)
    #: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 #f)))
+                           (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))))
+                  (vector->list
+                   (assoc-ref details "availability"))))))
+          (vector->list substitute-availability)))
 
-
+      (h2 "Packages")
       (div
        (table
         (@ (style "border-collapse: collapse;"))
@@ -114,3 +167,58 @@
                '((tr
                   (td (@ (colspan 7))
                       "Comparison unavailable")))))))))))
+
+(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))))
+                  (vector->list
+                   (assoc-ref details "availability"))))))
+          (vector->list substitute-availability)))))))
diff --git a/guix-qa-frontpage/view/home.scm b/guix-qa-frontpage/view/home.scm
index cfb1710..ddefa8d 100644
--- a/guix-qa-frontpage/view/home.scm
+++ b/guix-qa-frontpage/view/home.scm
@@ -18,17 +18,23 @@
        (a (@ (href "mailto:mail@cbaines.net"))
           "mail@cbaines.net")
        ".")
-      ;; (div (@ (class "row"))
-      ;;      (section
-      ;;       (h2 "branch: master")))
-      ;; (h2 "Branches")
-      ;; (div
-      ;;  (@ (class "row two-element-row"))
-      ;;  (section
-      ;;   (h3 "branch: staging"))
-      ;;  (section
-      ;;   (h3 "branch: staging")))
-      (h2 "Patches")
+      (div
+       (@ (class "row"))
+       (section
+        (a (@ (href "/branch/master"))
+           (h2 "branch: master"))))
+
+      (h2 "Branches")
+      (div
+       (@ (class "row two-element-row"))
+       (section
+        (a (@ (href "/branch/staging"))
+           (h3 "branch: staging")))
+       (section
+        (a (@ (href "/branch/core-updates"))
+           (h3 "branch: core-updates"))))
+
+      (h2 ,(gettext "Patches" "guix-qa-frontpage"))
       (a (@ (href "/patches"))
          "List of issues for patches")
       ;; (div