Show build information when comparing package derivations

As this is useful to see, as it can indicate that a change to the derivation
has led to the builds to start failing/succeeding.

2 files changed, 37 insertions, 16 deletions

diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm
index f2d7e46..7d2785a 100644
--- a/guix-data-service/web/compare/controller.scm
+++ b/guix-data-service/web/compare/controller.scm
@@ -34,6 +34,7 @@
   #:use-module (guix-data-service jobs load-new-guix-revision)
   #:use-module (guix-data-service model guix-revision)
   #:use-module (guix-data-service model derivation)
+  #:use-module (guix-data-service model build-server)
   #:use-module (guix-data-service model build-status)
   #:use-module (guix-data-service model lint-warning-message)
   #:use-module (guix-data-service web compare html)
@@ -528,13 +529,17 @@
                      valid-systems))
                    (targets
                     (with-thread-postgresql-connection
-                     valid-targets)))
+                     valid-targets))
+                   (build-server-urls
+                    (with-thread-postgresql-connection
+                     select-build-server-urls-by-id)))
          (render-html
           #:sxml (compare/package-derivations
                   query-parameters
                   systems
                   (valid-targets->options targets)
                   build-status-strings
+                  build-server-urls
                   '())))))
 
       (let ((base-commit    (assq-ref query-parameters 'base_commit))
@@ -550,7 +555,10 @@
                        (commit->revision-id conn base-commit)
                        (commit->revision-id conn target-commit)
                        #:systems systems
-                       #:targets targets)))))
+                       #:targets targets))))
+                  (build-server-urls
+                   (with-thread-postgresql-connection
+                    select-build-server-urls-by-id)))
           (let ((names-and-versions
                  (package-derivation-data->names-and-versions data)))
             (let-values
@@ -580,6 +588,7 @@
                               systems
                               (valid-targets->options targets)
                               build-status-strings
+                              build-server-urls
                               derivation-changes)
                       #:extra-headers http-headers-for-unchanging-content)))))))))))
 
diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm
index 7c34d7b..f4105c1 100644
--- a/guix-data-service/web/compare/html.scm
+++ b/guix-data-service/web/compare/html.scm
@@ -22,6 +22,7 @@
   #:use-module (texinfo)
   #:use-module (texinfo html)
   #:use-module (guix-data-service web query-parameters)
+  #:use-module (guix-data-service web html-utils)
   #:use-module (guix-data-service web view html)
   #:export (compare
             compare/derivation
@@ -602,6 +603,7 @@
                                      valid-systems
                                      valid-targets
                                      valid-build-statuses
+                                     build-server-urls
                                      derivation-changes)
   (layout
    #:body
@@ -681,7 +683,7 @@
               (th "Version")
               (th "System")
               (th "Target")
-              (th (@ (class "col-xs-5")) "Derivations")
+              (th (@ (class "col-xs-5")) "Derivations (with build statuses)")
               (th "")))
             (tbody
              ,@(append-map
@@ -704,18 +706,24 @@
                            (map
                             (match-lambda
                               ((system . target)
-                               (let ((base-derivation-file-name
-                                      (assq-ref (find (lambda (details)
-                                                        (and (string=? (assq-ref details 'system) system)
-                                                             (string=? (assq-ref details 'target) target)))
-                                                      (vector->list base-derivations))
-                                                'derivation-file-name))
-                                     (target-derivation-file-name
-                                      (assq-ref (find (lambda (details)
-                                                        (and (string=? (assq-ref details 'system) system)
-                                                             (string=? (assq-ref details 'target) target)))
-                                                      (vector->list target-derivations))
-                                                'derivation-file-name)))
+                               (let* ((base-entry
+                                       (find (lambda (details)
+                                               (and (string=? (assq-ref details 'system) system)
+                                                    (string=? (assq-ref details 'target) target)))
+                                             (vector->list base-derivations)))
+                                      (base-derivation-file-name
+                                       (assq-ref base-entry 'derivation-file-name))
+                                      (base-builds
+                                       (assq-ref base-entry 'builds))
+                                      (target-entry
+                                       (find (lambda (details)
+                                               (and (string=? (assq-ref details 'system) system)
+                                                    (string=? (assq-ref details 'target) target)))
+                                             (vector->list target-derivations)))
+                                      (target-derivation-file-name
+                                       (assq-ref target-entry 'derivation-file-name))
+                                      (target-builds
+                                       (assq-ref target-entry 'builds)))
                                  `((td (samp (@ (style "white-space: nowrap;"))
                                              ,system))
                                    (td (samp (@ (style "white-space: nowrap;"))
@@ -725,6 +733,8 @@
                                                      (href ,base-derivation-file-name))
                                                   (span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
                                                            (style "font-size: 1.5em; padding-right: 0.4em;")))
+                                                  ,@(build-statuses->build-status-labels
+                                                     (vector->list base-builds))
                                                   ,(display-store-item-short base-derivation-file-name)))
                                              '())
                                        ,@(if target-derivation-file-name
@@ -732,7 +742,9 @@
                                                      (href ,target-derivation-file-name))
                                                   (span (@ (class "text-success glyphicon glyphicon-plus pull-left")
                                                            (style "font-size: 1.5em; padding-right: 0.4em;")))
-                                                  ,(and=> target-derivation-file-name display-store-item-short)))
+                                                  ,@(build-statuses->build-status-labels
+                                                     (vector->list target-builds))
+                                                  ,(display-store-item-short target-derivation-file-name)))
                                              '()))
                                    (td (@ (style "vertical-align: middle;"))
                                        ,@(if (and base-derivation-file-name