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.

1 files changed, 145 insertions, 0 deletions

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)))