[no subject]

[Mathieu Othacehe]

branch: master
commit 1e8d075d706adb192eeb07302542448b4341fdf0
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sat Jan 30 14:24:29 2021 +0100

    Improve workers page.
    
    * src/cuirass/templates.scm (workers-status): Improve display.
    * src/cuirass/http.scm (url-handler): Adapt it.
---
 src/cuirass/http.scm      | 20 ++++++------
 src/cuirass/templates.scm | 77 +++++++++++++++++++++++++++++++++--------------
 2 files changed, 65 insertions(+), 32 deletions(-)

diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 6bca85c..a37c63a 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -651,15 +651,17 @@ Hydra format."
      (respond-html
       (html-page
        "Workers status"
-       (let ((workers (db-get-workers)))
-         (workers-status
-          workers
-          (map (lambda (worker)
-                 (let ((name (worker-name worker)))
-                   (db-get-builds `((worker . ,name)
-                                    (status . started)
-                                    (order . status+submission-time)))))
-               workers)))
+       (let* ((workers (db-get-workers))
+              (builds  (db-get-builds `((status . started)
+                                        (order . status+submission-time))))
+              (builds* (map (lambda (build)
+                              (let* ((id (assoc-ref build #:id))
+                                     (percentage
+                                      (db-get-build-percentage id)))
+                                `(,@build
+                                  (#:percentage . ,percentage))))
+                            builds)))
+         (workers-status workers builds*))
        '())))
 
     (('GET "metrics")
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index c32c0aa..b59c62b 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -1033,27 +1033,58 @@ completed builds divided by the time required to build 
them.")
       (td (a (@ (href "/build/" ,(assq-ref build #:id) "/log/raw"))
              "raw"))))
 
-  (define (worker-header worker)
-    `((p ,(integer->char 128994)
-         " "
-         (b ,(worker-name worker))
-         ,(format #f " (~a, ~{~a ~})"
-                  (worker-address worker)
-                  (worker-systems worker)))))
+  (define (machine-row machine)
+    (let* ((workers (filter (lambda (worker)
+                              (string=? (worker-machine worker)
+                                        machine))
+                            workers))
+           (builds
+            (map (lambda (worker)
+                   (match (filter
+                           (lambda (build)
+                             (let ((name (worker-name worker)))
+                               (let ((build-worker
+                                      (assq-ref build #:worker)))
+                                 (and build-worker
+                                      (string=? build-worker name)))))
+                                  builds)
+                     (() #f)
+                     ((build) build)))
+                        workers)))
+      `(div (@ (class "col-sm-4 mt-3"))
+            (h6 ,machine)
+            ,(map (lambda (worker build)
+                    (let ((name (worker-name worker))
+                          (style (format #f
+                                         "width: ~a%"
+                                         (if build
+                                             (assq-ref build #:percentage)
+                                             0))))
+                      `(div (@ (class "progress mt-1")
+                               (style "height: 20px"))
+                            (div (@ (class "progress-bar")
+                                    (role "progressbar")
+                                    (style ,style)
+                                    (aria-valuemin "0")
+                                    (aria-valuemax "100"))
+                                 ,(if build
+                                      `(strong
+                                        (@ (class "justify-content-center
+d-flex position-absolute w-100"))
+                                        (a (@ (class "text-dark")
+                                              (href "/build/"
+                                                    ,(assq-ref build #:id)
+                                                    "/details"))
+                                           ,(assq-ref build #:job-name)))
+                                      '(em
+                                        (@ (class "justify-content-center
+text-dark d-flex position-absolute w-100"))
+                                        "idle"))))))
+                  workers builds))))
 
-  (define (worker-table worker builds)
-    `(,@(worker-header worker)
-      (table
-       (@ (class "table table-sm table-hover table-striped"))
-       ,@(if (null? builds)
-             `((th (@ (scope "col")) "Idle"))
-             `((thead (tr (th (@ (scope "col")) "ID")
-                          (th (@ (scope "col")) "Job")
-                          (th (@ (scope "col")) "Queued at")
-                          (th (@ (scope "col")) "System")
-                          (th (@ (scope "col")) "Log")))
-               (tbody
-                ,(map build-row builds)))))))
-
-  `((p (@ (class "lead")) "Workers status")
-    ,@(map worker-table workers builds)))
+  (let ((machines (delete-duplicates
+                   (map worker-machine workers))))
+    `((p (@ (class "lead")) "Workers status")
+      (div (@ (class "container"))
+           (div (@ (class "row"))
+                ,@(map machine-row machines))))))