06/08: Implement more support for builds from the Guix Build Coordinator

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit 919255033121c0aeab6c4c16d58359a07b3408b5
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sun Jun 28 21:54:11 2020 +0100

    Implement more support for builds from the Guix Build Coordinator
    
    Builds from the Guix Build Coordinator might not have timestamps, and the id
    from the build server is more important, as one build server can build the
    same derivation many times.
---
 guix-data-service/builds.scm                      |  4 +-
 guix-data-service/model/build.scm                 | 97 ++++++++++++++++++++---
 guix-data-service/web/build-server/controller.scm | 23 ++++--
 guix-data-service/web/build-server/html.scm       | 12 +--
 guix-data-service/web/view/html.scm               | 21 +++--
 5 files changed, 128 insertions(+), 29 deletions(-)

diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm
index c3421b9..20cf094 100644
--- a/guix-data-service/builds.scm
+++ b/guix-data-service/builds.scm
@@ -284,6 +284,7 @@ WHERE derivation_output_details.path = $1"
                         conn
                         build-server-id
                         derivation
+                        #f
                         #:derivation-output-details-set-id
                         (match
                             (vhash-assoc
@@ -333,7 +334,8 @@ WHERE derivation_output_details.path = $1"
          (let ((build-id
                 (ensure-build-exists conn
                                      build-server-id
-                                     (assoc-ref data "derivation"))))
+                                     (assoc-ref data "derivation")
+                                     #f)))
            (insert-build-statuses-from-data
             conn
             build-server-id
diff --git a/guix-data-service/model/build.scm 
b/guix-data-service/model/build.scm
index 2a2cf99..9e81611 100644
--- a/guix-data-service/model/build.scm
+++ b/guix-data-service/model/build.scm
@@ -23,6 +23,7 @@
   #:export (select-build-stats
             select-builds-with-context
             select-builds-with-context-by-derivation-file-name
+            select-build-by-build-server-and-build-server-build-id
             select-build-by-build-server-and-derivation-file-name
             select-required-builds-that-failed
             update-builds-derivation-output-details-set-id
@@ -198,6 +199,7 @@ LIMIT 100"))
     "
 SELECT build_servers.id,
        build_servers.url,
+       builds.build_server_build_id,
        latest_build_status.timestamp,
        latest_build_status.status
 FROM builds
@@ -219,11 +221,50 @@ ORDER BY latest_build_status.timestamp DESC")
 
   (exec-query conn query (list derivation-file-name)))
 
+(define (select-build-by-build-server-and-build-server-build-id
+         conn build-server-id build-server-build-id)
+  (define query
+    "
+SELECT build_servers.url,
+       builds.derivation_file_name,
+       JSON_AGG(
+         json_build_object(
+           'timestamp', build_status.timestamp,
+           'status', build_status.status
+         )
+         ORDER BY build_status.timestamp
+       ) AS statuses
+FROM builds
+INNER JOIN build_servers
+  ON build_servers.id = builds.build_server_id
+INNER JOIN build_status
+  ON builds.id = build_status.build_id
+INNER JOIN derivations_by_output_details_set
+  ON builds.derivation_output_details_set_id =
+     derivations_by_output_details_set.derivation_output_details_set_id
+INNER JOIN derivations
+  ON derivations.id = derivations_by_output_details_set.derivation_id
+WHERE build_server_id = $1 AND
+      builds.build_server_build_id = $2
+GROUP BY build_servers.url, builds.derivation_file_name")
+
+  (match (exec-query conn
+                     query
+                     (list (number->string build-server-id)
+                           build-server-build-id))
+    (((build-server-url derivation-file-name statuses-json))
+     (list build-server-url
+           derivation-file-name
+           (json-string->scm statuses-json)))
+    (()
+     #f)))
+
 (define (select-build-by-build-server-and-derivation-file-name
          conn build-server-id derivation-file-name)
   (define query
     "
 SELECT build_servers.url,
+       builds.derivation_file_name,
        JSON_AGG(
          json_build_object(
            'timestamp', build_status.timestamp,
@@ -243,14 +284,17 @@ INNER JOIN derivations
   ON derivations.id = derivations_by_output_details_set.derivation_id
 WHERE build_server_id = $1 AND
       derivations.file_name = $2
-GROUP BY build_servers.url")
+GROUP BY build_servers.url, builds.derivation_file_name")
 
   (match (exec-query conn
                      query
                      (list (number->string build-server-id)
                            derivation-file-name))
-    (((build-server-url statuses-json))
+    (((build-server-url derivation-file-name statuses-json))
+     ;; Returning the derivation-file-name is for consistency with
+     ;; select-build-by-build-server-and-build-server-build-id
      (list build-server-url
+           derivation-file-name
            (json-string->scm statuses-json)))
     (()
      #f)))
@@ -310,6 +354,23 @@ WHERE build_server_id = $1 AND derivation_file_name = $2")
     (_
      #f)))
 
+(define (select-build-id-by-build-server-and-build-server-build-id
+         conn build-server-id build-server-build-id)
+  (define query
+    "
+SELECT id
+FROM builds
+WHERE build_server_id = $1 AND build_server_build_id = $2")
+
+  (match (exec-query conn
+                     query
+                     (list (number->string build-server-id)
+                           build-server-build-id))
+    (((id))
+     (string->number id))
+    (_
+     #f)))
+
 (define (update-builds-derivation-output-details-set-id conn 
derivation-file-names)
   (exec-query
    conn
@@ -344,16 +405,21 @@ WHERE derivations.file_name = $1"
     (_
      #f)))
 
-(define (insert-builds conn build-server-id derivation-file-names)
+(define (insert-builds conn build-server-id derivation-file-names
+                       build-server-build-ids)
   (let ((build-ids
          (insert-missing-data-and-return-all-ids
           conn
           "builds"
-          '(build_server_id derivation_file_name)
-          (map (lambda (derivation-file-name)
+          '(build_server_id derivation_file_name build_server_build_id)
+          (map (lambda (derivation-file-name build-server-build-id)
                  (list build-server-id
-                       derivation-file-name))
-               derivation-file-names)
+                       derivation-file-name
+                       (if (string? build-server-build-id)
+                           build-server-build-id
+                           '())))
+               derivation-file-names
+               build-server-build-ids)
           #:delete-duplicates? #t)))
 
     (exec-query
@@ -375,13 +441,15 @@ UPDATE builds SET derivation_output_details_set_id = (
     build-ids))
 
 (define* (insert-build conn build-server-id derivation-file-name
+                       build-server-build-id
                        #:key derivation-output-details-set-id)
   (match (exec-query
           conn
           (string-append
            "
 INSERT INTO builds
-  (build_server_id, derivation_file_name, derivation_output_details_set_id)
+  (build_server_id, derivation_file_name, derivation_output_details_set_id,
+   build_server_build_id)
 VALUES ("
            (number->string build-server-id)
            ", "
@@ -396,6 +464,10 @@ VALUES ("
                derivation-file-name))
              number->string)
             "NULL")
+           ", "
+           (or (and=> build-server-build-id
+                      quote-string)
+               "NULL")
            ")
 RETURNING (id)"))
     (((id))
@@ -404,10 +476,14 @@ RETURNING (id)"))
 (define* (ensure-build-exists conn
                               build-server-id
                               derivation-file-name
+                              build-server-build-id
                               #:key derivation-output-details-set-id)
   (let ((existing-build-id
-         (select-build-id-by-build-server-and-derivation-file-name
-          conn build-server-id derivation-file-name)))
+         (if build-server-build-id
+             (select-build-id-by-build-server-and-build-server-build-id
+              conn build-server-id build-server-build-id)
+             (select-build-id-by-build-server-and-derivation-file-name
+              conn build-server-id derivation-file-name))))
 
     (if existing-build-id
         (begin
@@ -423,5 +499,6 @@ WHERE builds.id = $1 AND derivation_output_details_set_id 
IS NULL"
         (insert-build conn
                       build-server-id
                       derivation-file-name
+                      build-server-build-id
                       #:derivation-output-details-set-id
                       derivation-output-details-set-id))))
diff --git a/guix-data-service/web/build-server/controller.scm 
b/guix-data-service/web/build-server/controller.scm
index c9db9a0..c68ef7d 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -53,18 +53,25 @@
                              #f))))
       (let* ((derivation-file-name
               (assq-ref query-parameters 'derivation_file_name))
+             (build-server-build-id
+              (assq-ref query-parameters 'build_server_build_id))
              (build
-              (select-build-by-build-server-and-derivation-file-name
-               conn
-               build-server-id
-               derivation-file-name)))
+              (if build-server-build-id
+                  (select-build-by-build-server-and-build-server-build-id
+                   conn
+                   build-server-id
+                   build-server-build-id)
+                  (select-build-by-build-server-and-derivation-file-name
+                   conn
+                   build-server-id
+                   derivation-file-name))))
         (if build
             (render-html
              #:sxml
              (view-build query-parameters
                          build
                          (if (string=?
-                              (assoc-ref (last (vector->list (second build)))
+                              (assoc-ref (last (vector->list (third build)))
                                          "status")
                               "failed-dependency")
                              (select-required-builds-that-failed
@@ -105,6 +112,9 @@
                             build-server-id
                             (map (lambda (item)
                                    (assoc-ref item "derivation"))
+                                 items)
+                            (map (lambda (item)
+                                   (assoc-ref item "build_id"))
                                  items))))
         (insert-build-statuses
          conn
@@ -212,7 +222,8 @@
      (let ((parsed-query-parameters
             (parse-query-parameters
              request
-             `((derivation_file_name ,identity #:required)))))
+             `((derivation_file_name  ,identity)
+               (build_server_build_id ,identity)))))
        (render-build mime-types
                      conn
                      (string->number build-server-id)
diff --git a/guix-data-service/web/build-server/html.scm 
b/guix-data-service/web/build-server/html.scm
index 319ab79..0078e8e 100644
--- a/guix-data-service/web/build-server/html.scm
+++ b/guix-data-service/web/build-server/html.scm
@@ -27,9 +27,6 @@
 (define (view-build query-parameters
                     build
                     required-failed-builds)
-  (define derivation
-    (assq-ref query-parameters 'derivation_file_name))
-
   (layout
    #:body
    `(,(header)
@@ -43,13 +40,13 @@
       (div
        (@ (class "row"))
        ,@(match build
-           ((url statuses)
+           ((url derivation-file-name statuses)
             `((div
                (@ (class "col-sm-6"))
                (dl
                 (@ (class "dl-horizontal"))
                 (dt "Derivation")
-                (dd ,(display-possible-store-item derivation))
+                (dd ,(display-possible-store-item derivation-file-name))
                 (dt "Build server URL")
                 (dd (a (@ (href ,url))
                        ,url))))
@@ -65,7 +62,10 @@
                 (tbody
                  ,@(map (lambda (status)
                           `(tr
-                            (td ,(assoc-ref status "timestamp"))
+                            (td ,(let ((timestamp (assoc-ref status 
"timestamp")))
+                                   (if (eq? timestamp 'null)
+                                       "(unknown)"
+                                       timestamp)))
                             (td ,(build-status-span
                                   (assoc-ref status "status")))))
                         (vector->list statuses)))))))))
diff --git a/guix-data-service/web/view/html.scm 
b/guix-data-service/web/view/html.scm
index d734cd0..cf5421a 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -631,15 +631,24 @@ time."
                  ,(build-status-span "")))
               (map
                (match-lambda
-                 ((build-server-id build-server-url timestamp status)
+                 ((build-server-id build-server-url
+                                   build-server-build-id
+                                   timestamp status)
+                  (define build-url
+                    (if (string? build-server-build-id)
+                        (simple-format
+                         #f "/build-server/~A/build?build_server_build_id=~A"
+                         build-server-id
+                         build-server-build-id)
+                        (simple-format
+                         #f "/build-server/~A/build?derivation_file_name=~A"
+                         build-server-id
+                         (second derivation))))
+
                   `(div
                     (@ (class "text-center"))
                     (div
-                     (a (@ (href
-                            ,(simple-format
-                              #f 
"/build-server/~A/build?derivation_file_name=~A"
-                              build-server-id
-                              (second derivation))))
+                     (a (@ (href ,build-url))
                         ,(build-status-span status)))
                     (a (@ (style "display: inline-block; margin-top: 0.4em;")
                           (href ,(simple-format