Convert the client actions to happen over HTTP

There were a few issues with the previous approach, I was concerned about
trying to write to the SQLite database from two processes, it's already
segfaulting occasionally when accessing it from just one. Additionally, the
client actions were already doing things that should happen in the coordinator
process, like allocating builds.

I'm trying to not turn this in to a web app, but not doing very well. Although
having this information and these actions available over the network does make
it possible to build a web app frontend, which I've had in mind.

2 files changed, 353 insertions, 33 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
new file mode 100644
index 0000000..b517f69
--- /dev/null
+++ b/guix-build-coordinator/client-communication.scm
@@ -0,0 +1,294 @@
+;;; Guix Build Coordinator
+;;;
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of the guix-build-coordinator.
+;;;
+;;; The Guix Build Coordinator is free software; you can redistribute
+;;; it and/or modify it under the terms of the GNU General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; The Guix Build Coordinator 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-build-coordinator client-communication)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (rnrs bytevectors)
+  #:use-module (json)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (fibers web server)
+  #:use-module (system repl error-handling)
+  #:use-module (guix derivations)
+  #:use-module (guix-build-coordinator utils)
+  #:use-module (guix-build-coordinator datastore)
+  #:use-module (guix-build-coordinator coordinator)
+  #:export (start-client-request-server
+
+            send-submit-build-request
+            request-build-details
+            request-agents-list
+            send-create-agent-request
+            send-create-agent-password-request))
+
+(define (start-client-request-server secret-key-base
+                                     host
+                                     port
+                                     build-coordinator)
+  (call-with-error-handling
+   (lambda ()
+     (run-server
+      (lambda (request body)
+        (display
+         (format #f "~4a ~a\n"
+                 (request-method request)
+                 (uri-path (request-uri request))))
+        (apply values
+               (controller request
+                           (cons (request-method request)
+                                 (split-and-decode-uri-path
+                                  (uri-path (request-uri request))))
+                           body
+                           secret-key-base
+                           build-coordinator)))
+      #:host host
+      #:port port))
+   #:on-error 'backtrace))
+
+(define (controller request
+                    method-and-path-components
+                    raw-body
+                    secret-key-base
+                    build-coordinator)
+  (define datastore
+    (build-coordinator-datastore build-coordinator))
+
+  (define body
+    (if raw-body
+        (json-string->scm (utf8->string raw-body))
+        '()))
+
+  (define (controller-thunk)
+    (match method-and-path-components
+      (('GET "build" uuid)
+       (match (datastore-find-build datastore uuid)
+         (#f
+          (render-json '((error . "no build found"))
+                       #:code 404))
+         (build-details
+          (let ((derivation-inputs
+                 (map
+                  (lambda (derivation-input-details)
+                    (let ((builds (datastore-list-builds-for-output
+                                   datastore
+                                   (assq-ref derivation-input-details
+                                             'output))))
+                      `(,@derivation-input-details
+                        (builds . ,(list->vector builds)))))
+                  (datastore-find-derivation-inputs
+                   datastore
+                   (assq-ref build-details 'derivation-name))))
+                (setup-failures
+                 (map
+                  (lambda (setup-failure)
+                    `(,@setup-failure
+                      ,@(if (string=? (assq-ref setup-failure 'failure-reason)
+                                      "missing_inputs")
+                            `((missing-inputs
+                               . ,(map
+                                   (lambda (missing-input)
+                                     (let ((builds-for-missing-input
+                                            (datastore-list-builds-for-output
+                                             datastore
+                                             missing-input)))
+                                       `(,@missing-input
+                                         (builds . ,(list->vector
+                                                     builds-for-missing-input)))))
+                                   (datastore-list-setup-failure-missing-inputs
+                                    datastore
+                                    (assq-ref setup-failure 'id)))))
+                            '())))
+                  (datastore-list-setup-failures-for-build
+                   datastore
+                   (assq-ref build-details 'uuid)))))
+            (render-json
+             `(,@build-details
+               (derivation-inputs . ,(list->vector derivation-inputs))
+               (setup-failures    . ,(list->vector setup-failures))))))))
+      (('GET "agents")
+       (render-json
+        `((agents . ,(list->vector (datastore-list-agents datastore))))))
+      (('POST "agents")
+       (let ((uuid (new-agent
+                    datastore
+                    #:requested-uuid (assoc-ref body "requested-uuid")
+                    #:description (assoc-ref body "description"))))
+         (render-json
+          `((agent-id . ,uuid)))))
+      (('POST "agent" agent-id "passwords")
+       (let ((password (new-agent-password
+                        datastore
+                        #:agent agent-id)))
+         (render-json
+          `((new-password . ,password)))))
+      (('POST "builds")
+       (let ((derivation-file (assoc-ref body "derivation")))
+         (unless (file-exists? derivation-file)
+           (substitute-derivation derivation-file
+                                  #:substitute-urls
+                                  (vector->list
+                                   (assoc-ref body "substitute-urls"))))
+
+         (let ((submit-build-result
+                (apply
+                 submit-build
+                 `(,build-coordinator
+                   ,(read-derivation-from-file derivation-file)
+                   ,@(let ((priority (assoc-ref body "priority")))
+                       (if priority
+                           `(#:priority ,priority)
+                           '()))
+                   ,@(if (assoc-ref body "ignore-if-build-for-outputs-exists")
+                         '(#:ignore-if-build-for-outputs-exists? #t)
+                         '())
+                   ,@(if (assoc-ref
+                          body "ensure-all-related-derivation-outputs-have-builds")
+                         '(#:ensure-all-related-derivation-outputs-have-builds? #t)
+                         '())))))
+           (render-json submit-build-result))))
+      (_
+       (render-json
+        "not-found"
+        #:code 404))))
+
+  (call-with-error-handling
+   controller-thunk
+   #:on-error 'backtrace
+   #:post-error (lambda args
+                  (match method-and-path-components
+                    ((method path-components ...)
+                     (simple-format
+                      (current-error-port)
+                      "error: when processing: /~A ~A\n"
+                      method (string-join path-components "/"))))
+                  (render-json
+                   `((error . ,(simple-format #f "~A" args)))
+                   #:code 500))))
+
+(define* (render-json json #:key (extra-headers '())
+                      (code 200))
+  (list (build-response
+         #:code code
+         #:headers (append extra-headers
+                           '((content-type . (application/json))
+                             (vary . (accept)))))
+        (lambda (port)
+          (scm->json json port))))
+
+(define* (send-request coordinator-uri
+                       method
+                       path
+                       #:optional
+                       request-body)
+  (let-values (((response body)
+                (http-request (string->uri
+                               (string-append "http://localhost:8746"
+                                              path))
+                              #:method method
+                              #:body (and=> request-body scm->json-string)
+                              #:decode-body? #f)))
+    (if (>= (response-code response) 400)
+        (begin
+          (simple-format
+           (current-error-port)
+           "error: coordinator-http-request: ~A ~A: ~A\n"
+           method path (response-code response))
+          (let ((body
+                 (catch #t
+                   (lambda ()
+                     (if (equal? '(application/json (charset . "utf-8"))
+                                 (response-content-type response))
+                         (json-string->scm (utf8->string body))
+                         (utf8->string body)))
+                   (lambda (key . args)
+                     (simple-format
+                      (current-error-port)
+                      "error decoding body ~A ~A\n"
+                      key args)
+                     #f))))
+            (raise-exception
+             (make-exception-with-message
+              body))))
+        (values
+         (json-string->scm (utf8->string body))
+         response))))
+
+(define (send-submit-build-request
+         coordinator-uri
+         derivation-file-name
+         substitute-urls
+         requested-uuid
+         priority
+         ignore-if-build-for-derivation-exists?
+         ignore-if-build-for-outputs-exists?
+         ensure-all-related-derivation-outputs-have-builds?)
+  (send-request coordinator-uri
+                'POST
+                "/builds"
+                `((derivation      . ,derivation-file-name)
+                  (priority        . ,priority)
+                  ,@(if substitute-urls
+                        `((substitute-urls . ,(list->vector substitute-urls)))
+                        '())
+                  ,@(if ignore-if-build-for-derivation-exists?
+                        '((ignore-if-build-for-derivation-exists . #t))
+                        '())
+                  ,@(if ignore-if-build-for-outputs-exists?
+                        '((ignore-if-build-for-outputs-exists . #t))
+                        '())
+                  ,@(if ensure-all-related-derivation-outputs-have-builds?
+                        '((ensure-all-related-derivation-outputs-have-builds . #t))
+                        '()))))
+
+(define (request-build-details coordinator-uri
+                               uuid)
+  (send-request coordinator-uri
+                'GET
+                (string-append "/build/" uuid)))
+
+(define (request-agents-list coordinator-uri)
+  (send-request coordinator-uri
+                'GET
+                (string-append "/agents")))
+
+(define* (send-create-agent-request coordinator-uri
+                                    #:key
+                                    requested-uuid
+                                    description)
+  (send-request coordinator-uri
+                'POST
+                "/agents"
+                `(,@(if requested-uuid
+                        `((requested-uuid . ,requested-uuid))
+                        '())
+                  ,@(if description
+                        `((description . ,description))
+                        '()))))
+
+(define (send-create-agent-password-request coordinator-uri
+                                            agent-id)
+  (send-request coordinator-uri
+                'POST
+                (string-append "/agent/" agent-id "/passwords")))
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index f0987a4..0eb8bd0 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -85,41 +85,67 @@
                        #:key
                        requested-uuid
                        (priority 0)
+                       (ignore-if-build-for-derivation-exists? #f)
+                       (ignore-if-build-for-outputs-exists? #f)
                        (ensure-all-related-derivation-outputs-have-builds? #f))
-  (let ((datastore (build-coordinator-datastore build-coordinator))
-        (uuid (or requested-uuid (random-v4-uuid))))
-    (datastore-store-derivation datastore derivation)
-
-    (when ensure-all-related-derivation-outputs-have-builds?
-      (let ((derivations-lacking-builds
-             (datastore-list-related-derivations-with-no-build-for-outputs
-              datastore
-              (derivation-file-name derivation))))
-        (for-each
-         (lambda (related-derivation)
-           (let ((related-uuid (random-v4-uuid)))
-             (simple-format #t "submtiting ~A for related ~A\n"
-                            related-uuid
-                            related-derivation)
-             (datastore-store-build datastore
-                                    related-derivation
+  (define datastore (build-coordinator-datastore build-coordinator))
+
+  (define (build-for-derivation-exists?)
+    (not
+     (null? (datastore-list-builds-for-derivation
+             datastore
+             (derivation-file-name derivation)))))
+
+  (define (build-for-output-already-exists?)
+    (any
+     (match-lambda
+       ((name . derivation-output)
+        (let ((builds-for-output
+               (datastore-list-builds-for-output
+                datastore
+                (derivation-output-path derivation-output))))
+
+          (not (null? builds-for-output)))))
+     (derivation-outputs derivation)))
+
+  (if (and ignore-if-build-for-derivation-exists?
+           (build-for-derivation-exists?))
+      '((no-build-submitted . build-already-exists-for-this-derivation))
+      (if (and ignore-if-build-for-outputs-exists?
+               (build-for-output-already-exists?))
+          '((no-build-submitted . build-already-exists-for-a-output))
+
+          ;; Actually create a build
+          (let ((uuid (or requested-uuid (random-v4-uuid))))
+            (datastore-store-derivation datastore derivation)
+
+            (when ensure-all-related-derivation-outputs-have-builds?
+              (let ((derivations-lacking-builds
+                     (datastore-list-related-derivations-with-no-build-for-outputs
+                      datastore
+                      (derivation-file-name derivation))))
+                (for-each
+                 (lambda (related-derivation)
+                   (let ((related-uuid (random-v4-uuid)))
+                     (simple-format #t "submtiting ~A for related ~A\n"
                                     related-uuid
-                                    ;; Let the scheduler take care of
-                                    ;; the prioritisation
-                                    0)))
-         derivations-lacking-builds)))
-
-    (datastore-store-build datastore
-                           (derivation-file-name derivation)
-                           uuid
-                           priority)
-
-    (unless defer-allocation?
-      ;; This can be removed once allocation in the main coordinator process can
-      ;; be triggered
-      (allocate-builds build-coordinator))
-
-    uuid))
+                                    related-derivation)
+                     (datastore-store-build datastore
+                                            related-derivation
+                                            related-uuid
+                                            ;; Let the scheduler take care of
+                                            ;; the prioritisation
+                                            0)))
+                 derivations-lacking-builds)))
+
+            (datastore-store-build datastore
+                                   (derivation-file-name derivation)
+                                   uuid
+                                   priority)
+
+            (trigger-build-allocation build-coordinator)
+
+            `((build-submitted . ,uuid))))))
 
 (define* (new-agent datastore
                     #:key