Rework the builds and build_status tables as well as related code

Allow for build status information to be submitted by POST request. This
required some changes to the builds and build_status tables, as for example,
the Cuirass build id may not be available, and the derivation may not be know
yet, so just record the derivation file name.

16 files changed, 511 insertions, 230 deletions

diff --git a/Makefile.am b/Makefile.am
index e5dea6f..55083fd 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -94,6 +94,7 @@ SOURCES =							\
   guix-data-service/web/compare/controller.scm			\
   guix-data-service/web/compare/html.scm			\
   guix-data-service/web/controller.scm				\
+  guix-data-service/web/build-server/controller.scm		\
   guix-data-service/web/jobs/controller.scm			\
   guix-data-service/web/jobs/html.scm				\
   guix-data-service/web/query-parameters.scm			\
diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm
index 8a92586..4ac42fb 100644
--- a/guix-data-service/builds.scm
+++ b/guix-data-service/builds.scm
@@ -1,4 +1,5 @@
 (define-module (guix-data-service builds)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (ice-9 match)
   #:use-module (ice-9 iconv)
@@ -28,21 +29,59 @@
   (simple-format #t "\nFetching unseen derivations\n")
   (process-derivations conn id url))
 
+(define (insert-build-statuses-from-data conn build-server-id build-id data)
+  (define stop-statuses
+    (lset-difference string=?
+                     build-status-strings
+                     '("scheduled" "started")))
+
+  (let ((status-string
+         (assq-ref build-statuses
+                   (assoc-ref data "buildstatus")))
+        (existing-status-entries
+         (map second
+              (select-build-statuses-by-build-id conn
+                                                 build-id
+                                                 build-server-id)))
+        (timestamp
+         (assoc-ref data "timestamp"))
+        (starttime
+         (assoc-ref data "starttime"))
+        (stoptime
+         (assoc-ref data "stoptime")))
+    (map (match-lambda
+           ((timestamp status)
+            (insert-build-status conn build-id timestamp status)))
+         (filter
+          list?
+          (list
+           (unless (member "scheduled" existing-status-entries)
+             (list timestamp "scheduled"))
+           (when (and (< 0 starttime)
+                      (not (member "started" existing-status-entries)))
+             (list starttime "started"))
+           (when (and (< 0 stoptime)
+                      (not (member status-string existing-status-entries)))
+             (list stoptime status-string)))))))
+
 (define (process-pending-builds conn build-server-id url)
   (for-each
    (match-lambda
-     ((build-id internal-build-id derivation-id derivation-file-name)
-      (match (fetch-build url build-id)
-        (#f #f)
-        (() #f)
-        (status
-         (insert-build-status conn
-                              internal-build-id
-                              (assoc-ref status "starttime")
-                              (assoc-ref status "stoptime")
-                              (assq-ref build-statuses
-                                        (assoc-ref status "buildstatus")))))
-      (display ".")
+     ((build-id derivation-file-name)
+      (match (fetch-build url derivation-file-name)
+        (#f
+         (display ".")
+         #f)
+        (()
+         (display ".")
+         #f)
+        (data
+         (insert-build-statuses-from-data
+          conn
+          build-server-id
+          build-id
+          data)
+         (display "-")))
       ;; Try not to make to many requests at once
       (usleep 200)))
    (select-pending-builds conn build-server-id)))
@@ -51,48 +90,25 @@
   (for-each
    (match-lambda
      ((derivation-id derivation-file-name)
-      (and=> (fetch-build-for-derivation url derivation-file-name)
-             (lambda (status)
-               (let ((internal-build-id
-                      (ensure-build-exists conn
-                                           build-server-id
-                                           (assoc-ref status "id")
-                                           derivation-id
-                                           (assoc-ref status "timestamp"))))
-
-                 (insert-build-status conn
-                                      internal-build-id
-                                      (assoc-ref status "starttime")
-                                      (assoc-ref status "stoptime")
-                                      (assq-ref build-statuses
-                                                (assoc-ref status "buildstatus"))))))
-      (display ".")
+      (if
+       (and=> (fetch-build url derivation-file-name)
+              (lambda (data)
+                (let ((build-id
+                       (ensure-build-exists conn
+                                            build-server-id
+                                            derivation-file-name)))
+                  (insert-build-statuses-from-data
+                   conn
+                   build-server-id
+                   build-id
+                   data))
+                #t))
+       (display "-")
+       (display "."))
       ;; Try not to make to many requests at once
       (usleep 200)))
    (select-derivations-with-no-known-build conn)))
 
-(define (fetch-build-for-derivation url derivation-file-name)
-  (catch
-    #t
-    (lambda ()
-      (match (fetch-latest-builds-for-derivation url derivation-file-name)
-        ((or #f #())
-         (match (fetch-queued-builds-for-derivation url derivation-file-name)
-           ((or #f #())
-            (simple-format #t "\nwarning: couldn't find build for ~A on ~A\n"
-                           derivation-file-name
-                           url)
-            #f)
-           (#(status)
-            status)))
-        (#(status)
-         status)))
-    (lambda args
-      (simple-format #t "\nerror: couldn't fetch build for ~A on ~A\n"
-                     derivation-file-name url)
-      (simple-format #t "error: ~A\n" args)
-      #f)))
-
 (define (json-string->scm* string)
   (catch
     'json-invalid
@@ -104,78 +120,58 @@
       (simple-format #t "\nerror parsing: ~A\n" string)
       #f)))
 
-(define (fetch-latest-builds-for-derivation base-url derivation-file-name)
-  (define url
-    (string-append base-url
-                   "api/latestbuilds?nr=1"
-                   "&derivation=" derivation-file-name))
-
-  (let-values (((response body) (http-request url)))
-    (let ((code (response-code response)))
-      (cond
-       ((eq? code 200)
-        (json-string->scm
-         (bytevector->string body "utf-8")))
-       (else
-        (simple-format #t "\nerror: response code ~A: ~A\n" url code)
-        #f)))))
-
-(define (fetch-queued-builds-for-derivation base-url derivation-file-name)
-  (define url
-    (string-append base-url
-                   "api/queue?nr=1"
-                   "&derivation=" derivation-file-name))
-
-  (let-values (((response body) (http-request url)))
-    (let ((code (response-code response)))
-      (cond
-       ((eq? code 200)
-        (json-string->scm
-         (bytevector->string body "utf-8")))
-       (else
-        (simple-format #t "\nerror: response code ~A: ~A\n" url code)
-        #f)))))
-
-(define (fetch-build url id)
+(define (fetch-build url derivation-file-name)
   (let-values
       (((response body)
-        (http-request (string-append url "build/" id))))
+        (http-request (string-append
+                       url
+                       (string-append
+                        "build"
+                        (string-drop
+                         derivation-file-name
+                         (string-length "/gnu/store")))))))
 
     (cond
      ((eq? (response-code response) 200)
       (json-string->scm
        (bytevector->string body "utf-8")))
      (else
-      (simple-format #t "\nwarning: couldn't find build ~A on ~A\n"
-                     id
-                     url)
       #f))))
 
 (define (select-pending-builds conn build-server-id)
   (define query
-    (string-append
-     "SELECT builds.id, builds.internal_id, derivations.id, derivations.file_name "
-     "FROM derivations "
-     "INNER JOIN builds "
-     "ON derivations.id = builds.derivation_id "
-     "INNER JOIN build_status "
-     "ON builds.internal_id = build_status.internal_build_id "
-     "WHERE builds.build_server_id = $1 AND "
-     "build_status.status IN ("
-     "'scheduled', 'started'"
-     ") "
-     "LIMIT 1000"))
-
-  (exec-query conn query (list (number->string build-server-id))))
+    "
+SELECT builds.id, derivations.file_name
+FROM derivations
+INNER JOIN builds
+  ON derivations.file_name = builds.derivation_file_name
+INNER JOIN build_status
+  ON builds.id = build_status.build_id
+WHERE builds.build_server_id = $1 AND
+      build_status.status IN (
+        'scheduled', 'started'
+      )
+LIMIT 1000")
+
+  (map
+   (match-lambda
+     ((build-id derivation-file-name)
+      (list (string->number build-id)
+            derivation-file-name)))
+   (exec-query conn query (list (number->string build-server-id)))))
 
 (define (select-derivations-with-no-known-build conn)
   (define query
-    (string-append
-     "SELECT derivations.id, derivations.file_name "
-     "FROM derivations "
-     "WHERE derivations.id NOT IN ("
-     "SELECT derivation_id FROM builds"
-     ") "
-     "LIMIT 15000"))
+    ;; Only select derivations that are in the package_derivations table, as
+    ;; Cuirass doesn't build the intermediate derivations
+    "
+SELECT derivations.id, derivations.file_name
+FROM derivations
+WHERE derivations.file_name NOT IN (
+  SELECT derivation_file_name FROM builds
+) AND derivations.id IN (
+  SELECT derivation_id FROM package_derivations
+)
+LIMIT 15000")
 
   (exec-query conn query))
diff --git a/guix-data-service/model/build-server-token-seed.scm b/guix-data-service/model/build-server-token-seed.scm
index 4a0c48d..454425b 100644
--- a/guix-data-service/model/build-server-token-seed.scm
+++ b/guix-data-service/model/build-server-token-seed.scm
@@ -12,10 +12,13 @@
                         secret-key-base
                         build-server-id
                         token-seed)))
-    (base64-encode
-     (bytevector-hash
-      (string->utf8 source-string)
-      (hash-algorithm sha1)))))
+    (string-filter
+     (base64-encode
+      (bytevector-hash
+       (string->utf8 source-string)
+       (hash-algorithm sha1)))
+     ;; Remove the + / and = to make handling the value easier
+     char-set:letter+digit)))
 
 (define (compute-tokens-for-build-server conn secret-key-base build-server-id)
   (define query
diff --git a/guix-data-service/model/build-status.scm b/guix-data-service/model/build-status.scm
index 26efde1..09f8623 100644
--- a/guix-data-service/model/build-status.scm
+++ b/guix-data-service/model/build-status.scm
@@ -1,8 +1,12 @@
 (define-module (guix-data-service model build-status)
+  #:use-module (ice-9 match)
   #:use-module (squee)
+  #:use-module (guix-data-service model utils)
   #:export (build-statuses
             build-status-strings
-            insert-build-status))
+            select-build-statuses-by-build-id
+            insert-build-status
+            insert-build-statuses))
 
 (define build-statuses
   '((-2 . "scheduled")
@@ -16,25 +20,63 @@
 (define build-status-strings
   (map cdr build-statuses))
 
-(define (insert-build-status conn internal-build-id
-                             starttime stoptime status)
-  (exec-query conn
+(define (select-build-statuses-by-build-id conn
+                                           build-id
+                                           build-server-id)
+  (define query
+    "
+SELECT timestamp, status
+FROM build_status
+INNER JOIN builds ON builds.id = build_status.build_id
+WHERE builds.build_server_id = $1 AND
+      builds.id = $2")
+
+  (exec-query conn query (list (number->string build-server-id)
+                               (number->string build-id))))
+
+(define (insert-build-status conn build-id timestamp status)
+  (define query
+    (string-append
+     "
+INSERT INTO build_status (build_id, timestamp, status)
+VALUES ("
+     (number->string build-id)
+     ", "
+     (string-append "to_timestamp("
+                    (number->string timestamp)
+                    ")")
+     ", "
+     (quote-string status)
+     ")"))
+
+  (exec-query conn query '()))
+
+(define (insert-build-statuses conn build-ids data)
+  (define query
+    (string-append
+     "
+INSERT INTO build_status (build_id, timestamp, status)
+VALUES "
+     (string-join
+      (map (match-lambda*
+             (((timestamp status) build-id)
+              (unless (member status build-status-strings)
+                (throw
+                 'invalid-status
+                 status))
+
               (string-append
-               "INSERT INTO build_status "
-               "(internal_build_id, starttime, stoptime, status) "
-               "VALUES "
-               "(" internal-build-id ", "
-               (if (eq? starttime 0)
-                   "NULL"
-                   (string-append "to_timestamp("
-                                  (number->string starttime)
-                                  ")"))
-               ", "
-               (if (eq? stoptime 0)
-                   "NULL"
-                   (string-append "to_timestamp("
-                                  (number->string stoptime)
-                                  ")"))
-               ", "
-               "'" status "'"
+               "("
+               (number->string build-id)
+               ","
+               (string-append "to_timestamp("
+                              (number->string timestamp)
+                              ")")
+               ","
+               (quote-string status)
                ")")))
+           data
+           build-ids)
+      ", ")))
+
+  (exec-query conn query '()))
diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm
index 74fe296..2e3385a 100644
--- a/guix-data-service/model/build.scm
+++ b/guix-data-service/model/build.scm
@@ -1,104 +1,122 @@
 (define-module (guix-data-service model build)
+  #:use-module (ice-9 match)
   #:use-module (squee)
+  #:use-module (guix-data-service model utils)
   #:export (select-build-stats
             select-builds-with-context
-            select-builds-with-context-by-derivation-id
-            select-build-by-build-server-and-id
+            select-builds-with-context-by-derivation-file-name
+            select-build-by-build-server-and-derivation-file-name
+            insert-builds
             insert-build
             ensure-build-exists))
 
 (define (select-build-stats conn)
   (define query
-    (string-append
-     "SELECT latest_build_status.status AS build_status, COUNT(*) "
-     "FROM derivations "
-     "FULL OUTER JOIN builds ON builds.derivation_id = derivations.id "
-     "FULL 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 "
-     "GROUP BY (builds.id IS NULL), latest_build_status.status "
-     "ORDER BY build_status"))
+    "
+SELECT latest_build_status.status AS build_status, COUNT(*)
+FROM derivations
+LEFT JOIN builds ON builds.derivation_file_name = derivations.file_name
+LEFT JOIN
+(
+  SELECT DISTINCT ON (build_id) *
+  FROM build_status
+  ORDER BY build_id, timestamp DESC
+) AS latest_build_status
+ON builds.id = latest_build_status.build_id
+GROUP BY latest_build_status.status
+ORDER BY status")
 
   (exec-query conn query))
 
 (define (select-builds-with-context conn)
   (define query
-    (string-append
-     "SELECT builds.id, build_servers.url, derivations.file_name, "
-     "latest_build_status.status_fetched_at, latest_build_status.starttime, "
-     "latest_build_status.stoptime, latest_build_status.status "
-     "FROM builds "
-     "INNER JOIN build_servers ON build_servers.id = builds.build_server_id "
-     "INNER JOIN derivations ON derivations.id = builds.derivation_id "
-     "INNER JOIN "
-     "(SELECT DISTINCT ON (internal_build_id) * "
-     "FROM build_status "
-     "ORDER BY internal_build_id, status_fetched_at DESC"
-     ") AS latest_build_status "
-     "ON latest_build_status.internal_build_id = builds.internal_id "
-     "ORDER BY latest_build_status.status_fetched_at DESC "
-     "LIMIT 100"))
+    "
+SELECT builds.id, build_servers.url, derivations.file_name,
+       latest_build_status.timestamp, latest_build_status.status
+FROM builds
+INNER JOIN build_servers ON build_servers.id = builds.build_server_id
+INNER JOIN derivations ON derivations.file_name = builds.derivation_file_name
+INNER JOIN
+(
+  SELECT DISTINCT ON (build_id) *
+  FROM build_status
+  ORDER BY build_id, timestamp DESC
+) AS latest_build_status
+ON latest_build_status.build_id = builds.id
+ORDER BY latest_build_status.timestamp DESC
+LIMIT 100")
 
   (exec-query conn query))
 
-(define (select-builds-with-context-by-derivation-id conn derivation-id)
+(define (select-builds-with-context-by-derivation-file-name
+         conn derivation-file-name)
   (define query
-    (string-append
-     "SELECT builds.id, build_servers.url, "
-     "latest_build_status.status_fetched_at, latest_build_status.starttime, "
-     "latest_build_status.stoptime, latest_build_status.status "
-     "FROM builds "
-     "INNER JOIN build_servers ON build_servers.id = builds.build_server_id "
-     "INNER JOIN "
-     "(SELECT DISTINCT ON (internal_build_id) * "
-     "FROM build_status "
-     "ORDER BY internal_build_id, status_fetched_at DESC"
-     ") AS latest_build_status "
-     "ON latest_build_status.internal_build_id = builds.internal_id "
-     "WHERE builds.derivation_id = $1 "
-     "ORDER BY latest_build_status.status_fetched_at DESC "))
+    "
+SELECT build_servers.url,
+       latest_build_status.timestamp,
+       latest_build_status.status
+FROM builds
+INNER JOIN build_servers ON build_servers.id = builds.build_server_id
+INNER JOIN
+(
+  SELECT DISTINCT ON (build_id) *
+  FROM build_status
+  ORDER BY build_id, timestamp DESC
+) AS latest_build_status
+ON latest_build_status.build_id = builds.id
+WHERE builds.derivation_file_name = $1
+ORDER BY latest_build_status.timestamp DESC")
 
-  (exec-query conn query (list (number->string derivation-id))))
+  (exec-query conn query (list derivation-file-name)))
 
-(define (select-build-by-build-server-and-id
-         conn build-server-id id)
-  (exec-query conn
-              (string-append
-               "SELECT internal_id, id, build_server_id, "
-               "derivation_id, timestamp "
-               "FROM builds "
-               "WHERE build_server_id = $1 AND id = $2")
-              (list build-server-id
-                    (number->string id))))
+(define (select-build-by-build-server-and-derivation-file-name
+         conn build-server-id derivation-file-name)
+  (define query
+    "
+SELECT id, build_server_id, derivation_file_name
+FROM builds
+WHERE build_server_id = $1 AND derivation_file_name = $2")
+
+  (match (exec-query conn
+                     query
+                     (list (number->string build-server-id)
+                           derivation-file-name))
+    ((id) (string->number id))
+    (_
+     #f)))
+
+(define (insert-builds conn build-server-id derivation-file-names)
+  (insert-missing-data-and-return-all-ids
+   conn
+   "builds"
+   '(build_server_id derivation_file_name)
+   (map (lambda (derivation-file-name)
+          (list build-server-id
+                derivation-file-name))
+        derivation-file-names)
+   #:delete-duplicates? #t))
 
-(define (insert-build conn id build-server-id derivation-id timestamp)
-  (caar
-   (exec-query conn
-               (string-append
-                "INSERT INTO builds "
-                "(id, build_server_id, derivation_id, timestamp) "
-                "VALUES "
-                "($1, $2, $3, to_timestamp($4))"
-                "RETURNING "
-                "(internal_id)")
-               (list (number->string id)
-                     build-server-id
-                     derivation-id
-                     (number->string timestamp)))))
+(define (insert-build conn build-server-id derivation-file-name)
+  (match (exec-query conn
+                     "
+INSERT INTO builds (build_server_id, derivation_file_name)
+VALUES ($1, $2)
+RETURNING (id)"
+                     (list (number->string build-server-id)
+                           derivation-file-name))
+    (((id))
+     (string->number id))))
 
-(define (ensure-build-exists conn build-server-id id
-                             derivation-id timestamp)
-  (let ((existing-build
-         (select-build-by-build-server-and-id
-          conn build-server-id id)))
+(define (ensure-build-exists conn
+                             build-server-id
+                             derivation-file-name)
+  (let ((existing-build-id
+         (select-build-by-build-server-and-derivation-file-name
+          conn build-server-id derivation-file-name)))
 
-    (if (null? existing-build)
+    (if existing-build-id
+        existing-build-id
         (insert-build conn
-                      id
                       build-server-id
-                      derivation-id
-                      timestamp)
-        (caar existing-build))))
+                      derivation-file-name))))
 
diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm
new file mode 100644
index 0000000..3141043
--- /dev/null
+++ b/guix-data-service/web/build-server/controller.scm
@@ -0,0 +1,145 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-data-service web build-server controller)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (json)
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service web render)
+  #:use-module (guix-data-service web query-parameters)
+  #:use-module (guix-data-service jobs load-new-guix-revision)
+  #:use-module (guix-data-service model build)
+  #:use-module (guix-data-service model build-status)
+  #:use-module (guix-data-service model build-server-token-seed)
+  #:use-module (guix-data-service web jobs html)
+  #:export (build-server-controller))
+
+(define (handle-build-event-submission parsed-query-parameters
+                                       build-server-id-string
+                                       body
+                                       conn
+                                       secret-key-base)
+  (define build-server-id
+    (string->number build-server-id-string))
+
+  (define (handle-derivation-events items)
+    (unless (null? items)
+      (let ((build-ids
+             (insert-builds conn
+                            build-server-id
+                            (map (lambda (item)
+                                   (assoc-ref item "derivation"))
+                                 items))))
+        (insert-build-statuses
+         conn
+         build-ids
+         (map
+          (lambda (item-data)
+            (list (assoc-ref item-data "timestamp")
+                  (assoc-ref item-data "event")))
+          items)))))
+
+  (define (process-items items)
+    (with-postgresql-transaction
+     conn
+     (lambda (conn)
+       (handle-derivation-events
+        (filter (lambda (item)
+                  (let ((type (assoc-ref item "type")))
+                    (if type
+                        (string=? type "build")
+                        (begin
+                          (simple-format (current-error-port)
+                                         "warning: unknown type for event: ~A\n"
+                                         item)
+                          #f))))
+                items)))))
+
+  (if (any-invalid-query-parameters? parsed-query-parameters)
+      (render-json
+       '((error . "no token provided"))
+       #:code 400)
+      (let ((provided-token (assq-ref parsed-query-parameters 'token))
+            (permitted-tokens (compute-tokens-for-build-server
+                               conn
+                               secret-key-base
+                               build-server-id)))
+        (if (member provided-token
+                    (map cdr permitted-tokens)
+                    string=?)
+            (catch
+              'json-invalid
+              (lambda ()
+                (let ((body-string (utf8->string body)))
+                  (let* ((body-json (json-string->scm body-string))
+                         (items (and=> (assoc-ref body-json "items")
+                                       vector->list)))
+                    (cond
+                     ((eq? items #f)
+                      (render-json
+                       '((error . "missing items key"))
+                       #:code 400))
+                     ((null? items)
+                      (render-json
+                       '((error . "no items to process"))
+                       #:code 400))
+                     (else
+                      (catch
+                        #t
+                        (lambda ()
+                          (process-items items)
+                          (no-content))
+                        (lambda (key . args)
+                          (simple-format (current-error-port)
+                                         "error processing events: ~A: ~A\n"
+                                         key
+                                         args)
+                          (for-each (lambda (item)
+                                      (simple-format (current-error-port)
+                                                     "  ~A\n" item))
+                                    items)
+                          (render-json
+                           '((error . "could not process events"))
+                           #:code 500))))))))
+              (lambda (key . args)
+                (render-json
+                 '((error . "could not parse body as JSON"))
+                 #:code 400)))
+            (render-json
+             '((error . "error"))
+             #:code 403)))))
+
+(define (build-server-controller request
+                                 method-and-path-components
+                                 mime-types
+                                 body
+                                 conn
+                                 secret-key-base)
+  (match method-and-path-components
+    (('POST "build-server" build-server-id "build-events")
+     (let ((parsed-query-parameters
+            (parse-query-parameters
+             request
+             `((token ,identity #:required)))))
+       (handle-build-event-submission parsed-query-parameters
+                                      build-server-id
+                                      body
+                                      conn
+                                      secret-key-base)))
+    (_ #f)))
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 1e8d46a..5c21f97 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -21,10 +21,12 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 pretty-print)
   #:use-module (ice-9 textual-ports)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (web request)
+  #:use-module (web response)
   #:use-module (web uri)
   #:use-module (texinfo)
   #:use-module (texinfo html)
@@ -53,6 +55,7 @@
   #:use-module (guix-data-service web revision controller)
   #:use-module (guix-data-service web jobs controller)
   #:use-module (guix-data-service web view html)
+  #:use-module (guix-data-service web build-server controller)
   #:use-module (guix-data-service web compare controller)
   #:use-module (guix-data-service web revision controller)
   #:use-module (guix-data-service web repository controller)
@@ -102,9 +105,9 @@
               (derivation-outputs (select-derivation-outputs-by-derivation-id
                                    conn
                                    (first derivation)))
-              (builds (select-builds-with-context-by-derivation-id
+              (builds (select-builds-with-context-by-derivation-file-name
                        conn
-                       (first derivation))))
+                       (second derivation))))
           (render-html
            #:sxml (view-derivation derivation
                                    derivation-inputs
@@ -176,7 +179,9 @@
       (static-asset-from-store-renderer)
       render-static-asset))
 
-(define (controller request method-and-path-components mime-types body)
+(define (controller request method-and-path-components
+                    mime-types body
+                    secret-key-base)
   (match method-and-path-components
     (('GET "assets" rest ...)
      (or (handle-static-assets (string-join rest "/")
@@ -223,13 +228,15 @@
                                              method-and-path-components
                                              mime-types
                                              body
-                                             conn))))))
+                                             conn
+                                             secret-key-base))))))
 
 (define (controller-with-database-connection request
                                              method-and-path-components
                                              mime-types
                                              body
-                                             conn)
+                                             conn
+                                             secret-key-base)
   (define path
     (uri-path (request-uri request)))
 
@@ -241,6 +248,15 @@
            conn)
         (not-found (request-uri request))))
 
+  (define (delegate-to-with-secret-key-base f)
+    (or (f request
+           method-and-path-components
+           mime-types
+           body
+           conn
+           secret-key-base)
+        (not-found (request-uri request))))
+
   (match method-and-path-components
     (('GET)
      (render-html
@@ -276,6 +292,8 @@
          (render-formatted-derivation conn
                                       (string-append "/gnu/store/" filename))
          (not-found (request-uri request))))
+    (((or 'GET 'POST) "build-server" _ ...)
+     (delegate-to-with-secret-key-base build-server-controller))
     (('GET "compare" _ ...)             (delegate-to compare-controller))
     (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
     (('GET "jobs")         (delegate-to jobs-controller))
diff --git a/guix-data-service/web/render.scm b/guix-data-service/web/render.scm
index eeaf99d..880035e 100644
--- a/guix-data-service/web/render.scm
+++ b/guix-data-service/web/render.scm
@@ -39,6 +39,7 @@
             not-found
             unprocessable-entity
             created
+            no-content
             redirect))
 
 (define file-mime-types
@@ -167,6 +168,10 @@
   (list (build-response #:code 201)
         ""))
 
+(define (no-content)
+  (list (build-response #:code 204)
+        ""))
+
 (define (redirect path)
   (let ((uri (build-uri 'http
                         #:host (%config 'host)
diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index 695558c..4f81d4c 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -27,25 +27,27 @@
   #:use-module (guix-data-service web util)
   #:export (start-guix-data-service-web-server))
 
-(define (run-controller controller request body)
+(define (run-controller controller request body secret-key-base)
   (let-values (((request-components mime-types)
                 (request->path-components-and-mime-type request)))
     (controller request
                 (cons (request-method request)
                       request-components)
                 mime-types
-                body)))
+                body
+                secret-key-base)))
 
-(define (handler request body controller)
+(define (handler request body controller secret-key-base)
   (display
    (format #f "~a ~a\n"
            (request-method request)
            (uri-path (request-uri request))))
   (apply values
-         (run-controller controller request body)))
+         (run-controller controller request body secret-key-base)))
 
-(define (start-guix-data-service-web-server port host)
+(define (start-guix-data-service-web-server port host secret-key-base)
   (run-server (lambda (request body)
-                (handler request body controller))
+                (handler request body controller
+                         secret-key-base))
               #:host host
               #:port port))
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 1792440..c514f4f 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -387,16 +387,19 @@
           ,@(map
              (match-lambda
                ((build-id build-server-url derivation-file-name
-                          status-fetched-at starttime stoptime status)
+                          timestamp status)
                 `(tr
                   (td (@ (class "text-center"))
                       ,(build-status-span status))
                   (td (a (@ (href ,derivation-file-name))
                          ,(display-store-item-short derivation-file-name)))
-                  (td ,starttime)
-                  (td ,stoptime)
+                  (td ,timestamp)
                   (td (a (@ (href ,(simple-format
-                                    #f "~Abuild/~A" build-server-url build-id)))
+                                    #f "~Abuild/~A"
+                                    build-server-url
+                                    (string-drop
+                                     derivation-file-name
+                                     (string-length "/gnu/store/")))))
                          "View build on " ,build-server-url)))))
              builds)))))))))
 
@@ -599,14 +602,17 @@
                  ,(build-status-span "")))
               (map
                (match-lambda
-                 ((build-id build-server-url status-fetched-at
-                            starttime stoptime status)
+                 ((build-server-url timestamp status)
                   `(div
                     (@ (class "text-center"))
                     (div ,(build-status-span status))
                     (a (@ (style "display: inline-block; margin-top: 0.4em;")
                           (href ,(simple-format
-                                  #f "~Abuild/~A" build-server-url build-id)))
+                                  #f "~Abuild/~A"
+                                  build-server-url
+                                  (string-drop
+                                   (second derivation)
+                                   (string-length "/gnu/store/")))))
                        "View build on " ,build-server-url))))
                builds)))
        (div
diff --git a/scripts/guix-data-service-query-build-servers.in b/scripts/guix-data-service-query-build-servers.in
index b0b3cd0..2662c89 100644
--- a/scripts/guix-data-service-query-build-servers.in
+++ b/scripts/guix-data-service-query-build-servers.in
@@ -23,6 +23,7 @@
 (use-modules (srfi srfi-1)
              (srfi srfi-37)
              (squee)
+             (guix-data-service database)
              (guix-data-service builds))
 
 (with-postgresql-connection "query-build-servers"
diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in
index e8b35b5..d91b659 100644
--- a/scripts/guix-data-service.in
+++ b/scripts/guix-data-service.in
@@ -25,6 +25,7 @@
 
 (use-modules (srfi srfi-1)
              (srfi srfi-37)
+             (ice-9 textual-ports)
              (system repl server)
              (guix-data-service config)
              (guix-data-service web server))
@@ -49,6 +50,12 @@
                   (alist-cons 'pid-file
                               arg
                               result)))
+        (option '("secret-key-base-file") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'secret-key-base
+                              (string-trim-right
+                               (call-with-input-file arg get-string-all))
+                              result)))
         (option '("update-database") #f #f
                 (lambda (opt name _ result)
                   (alist-cons 'update-database #t result)))
@@ -123,4 +130,5 @@
                  (assq-ref opts 'port))
 
   (start-guix-data-service-web-server (assq-ref opts 'port)
-                                      (assq-ref opts 'host)))
+                                      (assq-ref opts 'host)
+                                      (assq-ref opts 'secret-key-base)))
diff --git a/sqitch/deploy/rework_builds.sql b/sqitch/deploy/rework_builds.sql
new file mode 100644
index 0000000..3edfc2d
--- /dev/null
+++ b/sqitch/deploy/rework_builds.sql
@@ -0,0 +1,21 @@
+-- Deploy guix-data-service:rework_builds to pg
+
+BEGIN;
+
+DROP TABLE build_status;
+DROP TABLE builds;
+
+CREATE TABLE builds (
+    id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+    build_server_id integer NOT NULL REFERENCES build_servers(id),
+    derivation_file_name varchar NOT NULL
+);
+
+CREATE TABLE build_status (
+    id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+    build_id integer NOT NULL REFERENCES builds(id),
+    "timestamp" timestamp without time zone DEFAULT clock_timestamp() NOT NULL,
+    status guix_data_service.buildstatus NOT NULL
+);
+
+COMMIT;
diff --git a/sqitch/revert/rework_builds.sql b/sqitch/revert/rework_builds.sql
new file mode 100644
index 0000000..507808d
--- /dev/null
+++ b/sqitch/revert/rework_builds.sql
@@ -0,0 +1,7 @@
+-- Revert guix-data-service:rework_builds from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index d3d9c7a..5990567 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -28,3 +28,4 @@ remove_guix_revision_duplicates 2019-10-05T08:00:14Z Christopher Baines <mail@cb
 package_derivations_by_guix_revision_range 2019-11-09T19:09:48Z Christopher Baines <mail@cbaines.net> # Add package_derivations_by_guix_revision_range
 channel_news_tables 2019-11-15T07:32:07Z Christopher Baines <mail@cbaines.net> # Add tables to store channel news
 build_server_token_seeds 2019-11-23T09:26:48Z Christopher Baines <mail@cbaines.net> # Add build_server_token_seeds table
+rework_builds 2019-11-23T20:41:20Z Christopher Baines <mail@cbaines.net> # Rework the build tables
diff --git a/sqitch/verify/rework_builds.sql b/sqitch/verify/rework_builds.sql
new file mode 100644
index 0000000..2dd6a15
--- /dev/null
+++ b/sqitch/verify/rework_builds.sql
@@ -0,0 +1,7 @@
+-- Verify guix-data-service:rework_builds on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;