Show more information about branches, including substitute availability

4 files changed, 192 insertions, 19 deletions

diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm
index 7f66ead..0ac3050 100644
--- a/guix-qa-frontpage/guix-data-service.scm
+++ b/guix-qa-frontpage/guix-data-service.scm
@@ -37,7 +37,10 @@
             revision-details-url
 
             revision-system-tests-url
-            revision-system-tests))
+            revision-system-tests
+
+            package-substitute-availability-url
+            package-substitute-availability))
 
 (define-exception-type &guix-data-service-error &error
   make-guix-data-service-error
@@ -255,3 +258,20 @@
                   (assoc-ref json-body "system_tests")))))))
    #:times 6
    #:delay 5))
+
+(define* (package-substitute-availability-url commit)
+  (simple-format
+   #f
+   "https://data.qa.guix.gnu.org/revision/~A/package-substitute-availability.json"
+   commit))
+
+(define (package-substitute-availability url)
+  (retry-on-error
+   (lambda ()
+     (let ((json-body
+            (guix-data-service-request url)))
+       (if json-body
+           (assoc-ref json-body "substitute_servers")
+           #f)))
+   #:times 1
+   #:delay 5))
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index 02929b8..ce4b9ee 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -106,9 +106,20 @@
          (render-html
           #:sxml
           (branches-view branches))))
+      (('GET "branch" "master")
+       (let ((substitute-availability
+              (with-sqlite-cache
+               database
+               'master-branch-data
+               master-branch-data
+               #:ttl 6000)))
+         (render-html
+          #:sxml
+          (master-branch-view substitute-availability))))
       (('GET "branch" branch)
        (let ((change-details
               derivation-changes-counts
+              substitute-availability
               (with-sqlite-cache
                database
                'branch-data
@@ -120,7 +131,8 @@
           #:sxml
           (branch-view branch
                        change-details
-                       derivation-changes-counts))))
+                       derivation-changes-counts
+                       substitute-availability))))
       (('GET "patches")
        (let* ((latest-series
                (with-sqlite-cache
@@ -468,11 +480,32 @@ port. Also, the port used can be changed by passing the --port option.\n"
          (derivation-changes-counts
           (derivation-changes-counts
            derivation-changes-data
-           %systems-to-submit-builds-for)))
+           %systems-to-submit-builds-for))
+
+         (target-commit
+          (assoc-ref
+           (assoc-ref
+            (assoc-ref change-details "revisions")
+            "target")
+           "commit"))
+
+         (substitute-availability
+          (package-substitute-availability
+           (package-substitute-availability-url
+            target-commit))))
 
     (values
      change-details
-     derivation-changes-counts)))
+     derivation-changes-counts
+     substitute-availability)))
+
+(define* (master-branch-data)
+  (let* ((substitute-availability
+          (package-substitute-availability
+           "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-substitute-availability.json")))
+
+    (values
+     substitute-availability)))
 
 (define* (start-refresh-patch-branches-data-thread
           database
@@ -629,7 +662,13 @@ port. Also, the port used can be changed by passing the --port option.\n"
                 #:ttl (/ frequency 2))))
            #:unwind? #t)
          #t)
-       branches)))
+       branches))
+
+    (with-sqlite-cache
+     database
+     'master-branch-data
+     master-branch-data
+     #:ttl 0))
 
   (call-with-new-thread
    (lambda ()
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