Include the status of derivations

On the comparison page.

4 files changed, 63 insertions, 22 deletions

diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index 3fc6215..e3190ad 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -8,6 +8,7 @@
   #:export (package-data->package-data-vhashes
             package-differences-data
             package-data-vhash->derivations
+            package-data-vhash->derivations-and-build-status
             package-data-vhashes->new-packages
             package-data-vhashes->removed-packages
             package-data-version-changes
@@ -61,6 +62,20 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
           (select-derivations-by-id conn derivation-ids)))
     derivation-data))
 
+(define (package-data-vhash->derivations-and-build-status conn packages-vhash)
+  (define (vhash->derivation-ids vhash)
+    (vhash-fold (lambda (key value result)
+                  (cons (third value)
+                        result))
+                '()
+                vhash))
+
+  (let* ((derivation-ids
+          (vhash->derivation-ids packages-vhash))
+         (derivation-data
+          (select-derivations-and-build-status-by-id conn derivation-ids)))
+    derivation-data))
+
 (define (package-data-vhash->package-name-and-version-vhash vhash)
   (vhash-fold (lambda (name details result)
                 (vhash-cons (cons name (first details))
diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm
index ef39251..a83bf97 100644
--- a/guix-data-service/model/derivation.scm
+++ b/guix-data-service/model/derivation.scm
@@ -9,6 +9,7 @@
   #:use-module (guix-data-service model utils)
   #:export (select-existing-derivations
             select-derivations-by-id
+            select-derivations-and-build-status-by-id
             insert-into-derivations
             derivations->derivation-ids))
 
@@ -289,6 +290,27 @@
 
   (exec-query conn query))
 
+(define (select-derivations-and-build-status-by-id conn ids)
+  (define query
+    (string-append
+     "SELECT derivations.id, derivations.file_name, latest_build_status.status "
+     "FROM derivations "
+     "LEFT OUTER JOIN builds ON derivations.id = builds.derivation_id "
+     "LEFT OUTER JOIN "
+     "(SELECT DISTINCT ON (internal_build_id) * "
+     "FROM build_status "
+     "ORDER BY internal_build_id, status_fetched_at DESC"
+     ") AS latest_build_status "
+     "ON builds.internal_id = latest_build_status.internal_build_id "
+     "WHERE derivations.id IN "
+     "(" (string-join (map (lambda (id)
+                             (simple-format #f "'~A'" id))
+                           ids)
+                      ",")
+     ");"))
+
+  (exec-query conn query))
+
 (define (derivations->derivation-ids conn derivations)
   (define (ensure-input-derivations-exist)
     (let* ((missing-derivation-file-names (map derivation-file-name
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 3299379..145cc01 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -142,27 +142,27 @@
                                    base-revision-id
                                    target-revision-id))))
     (let ((base-derivations
-           (package-data-vhash->derivations
+           (package-data-vhash->derivations-and-build-status
             conn
             base-packages-vhash))
           (target-derivations
-           (package-data-vhash->derivations
+           (package-data-vhash->derivations-and-build-status
             conn
             target-packages-vhash)))
-    (cond
-     ((eq? content-type 'json)
-      (render-json
-       `((base . ((commit . ,base-commit)
-                  (derivations . ,base-derivations)))
-         (target . ((commit . ,target-commit)
-                    (derivations . ,target-derivations))))))
-     (else
-      (apply render-html
-             (compare/derivations
-              base-commit
-              target-commit
-              base-derivations
-              target-derivations)))))))
+      (cond
+       ((eq? content-type 'json)
+        (render-json
+         `((base . ((commit . ,base-commit)
+                    (derivations . ,base-derivations)))
+           (target . ((commit . ,target-commit)
+                      (derivations . ,target-derivations))))))
+       (else
+        (apply render-html
+               (compare/derivations
+                base-commit
+                target-commit
+                base-derivations
+                target-derivations)))))))
 
 (define (render-compare/packages content-type
                                  conn
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index ebf2c20..d998c79 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -326,13 +326,15 @@
         (@ (class "table"))
         (thead
          (tr
-          (th (@ (class "col-md-12")) "File Name")))
+          (th (@ (class "col-md-8")) "File Name")
+          (th (@ (class "col-md-4")) "Build status")))
         (tbody
          ,@(map
             (match-lambda
-              ((id file-name)
+              ((id file-name build-status)
                `(tr
-                 (td ,file-name))))
+                 (td ,file-name)
+                 (td ,build-status))))
             base-derivations))))
       (div
        (@ (class "row"))
@@ -344,13 +346,15 @@
         (@ (class "table"))
         (thead
          (tr
-          (th (@ (class "col-md-12")) "File Name")))
+          (th (@ (class "col-md-8")) "File Name")
+          (th (@ (class "col-md-4")) "Build status")))
         (tbody
          ,@(map
             (match-lambda
-              ((id file-name)
+              ((id file-name build-status)
                `(tr
-                 (td ,file-name))))
+                 (td ,file-name)
+                 (td ,build-status))))
             target-derivations))))))))
 
 (define (compare/packages base-commit