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, 134 insertions, 138 deletions

diff --git a/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in b/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in
index 035fcfe..9cf0da2 100644
--- a/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in
+++ b/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in
@@ -130,11 +130,6 @@
                   (string-append
                    "--derivation-substitute-urls="
                    "https://" %guix-data-service-host)
-                  ;; Currently submitting builds performs an allocation. Ideally this
-                  ;; would just mark the plan as dirty to avoid repeatedly
-                  ;; re-allocating builds. Until that point, pass this flag to skip
-                  ;; allocating builds.
-                  "--defer-allocation"
                   ;; For the use case of providing substitutes, just build each
                   ;; output once.
                   "--ignore-if-build-for-derivation-exists"
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 52122bd..e5493de 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -37,7 +37,8 @@
              (guix-build-coordinator datastore)
              (guix-build-coordinator coordinator)
              (guix-build-coordinator build-allocator)
-             (guix-build-coordinator agent-messaging http))
+             (guix-build-coordinator agent-messaging http)
+             (guix-build-coordinator client-communication))
 
 (define %base-options
   ;; Specifications of the command-line options
@@ -71,6 +72,16 @@
           ("" #f)
           (_ #t)))))
 
+(define %client-options
+  (list (option '("coordinator") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'coordinator
+                              arg
+                              (alist-delete 'coordinator result))))))
+
+(define %client-option-defaults
+  '((coordinator . "http://localhost:8746")))
+
 (define %build-options
   (list (option '("priority") #t #f
                 (lambda (opt name arg result)
@@ -92,18 +103,13 @@
                 (lambda (opt name arg result)
                   (alist-cons 'derivation-substitute-urls
                               (string-split arg #\space)
-                              result)))
-        (option '("defer-allocation") #f #f
-                (lambda (opt name _ result)
-                  (alist-cons 'defer-allocation #t result)))))
-
+                              result)))))
 
 (define %build-option-defaults
   `((priority                                          . 0)
     (ignore-if-build-for-derivation-exists             . #f)
     (ignore-if-build-for-outputs-exists                . #f)
-    (ensure-all-related-derivation-outputs-have-builds . #f)
-    (defer-allocation                                  . #f)))
+    (ensure-all-related-derivation-outputs-have-builds . #f)))
 
 (define %service-options
   (list (option '("pid-file") #t #f
@@ -116,6 +122,11 @@
                   (alist-cons 'agent-communication
                               arg
                               (alist-delete 'agent-communication result))))
+        (option '("client-communication") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'client-communication
+                              arg
+                              (alist-delete 'client-communication result))))
         (option '("allocation-strategy") #t #f
                 (lambda (opt name arg result)
                   (alist-cons
@@ -151,6 +162,7 @@
 (define %service-option-defaults
   ;; Alist of default option values
   `((agent-communication                  . "http://0.0.0.0:8745")
+    (client-communication                 . "http://127.0.0.1:8746")
     (allocation-strategy                  . ,basic-build-allocation-strategy)
     (build-success-hook                   . ,default-build-success-hook)
     (build-failure-hook                   . ,default-build-failure-hook)
@@ -225,159 +237,139 @@
    (let ((opts (parse-options %base-options
                               %base-option-defaults
                               rest)))
-     (let ((datastore (database-uri->datastore
-                       (assq-ref opts 'database))))
-       (define (display-build build-details)
-         (simple-format #t "derivation name: ~A
+     (define (display-build build-details)
+       (simple-format #t "derivation name: ~A
 priority:        ~A
 processed?:      ~A
 "
-                        (assq-ref build-details 'derivation-name)
-                        (assq-ref build-details 'priority)
-                        (assq-ref build-details 'processed))
-
-         (let ((setup-failures
-                (datastore-list-setup-failures-for-build
-                 datastore
-                 (assq-ref build-details 'uuid))))
-           (unless (null? setup-failures)
-             (display "\nsetup failures:\n")
-             (for-each
-              (lambda (setup-failure)
-                (simple-format #t "  - agent:          ~A
+                      (assoc-ref build-details "derivation-name")
+                      (assoc-ref build-details "priority")
+                      (if (assoc-ref build-details "processed")
+                          "yes"
+                          "no"))
+
+       (let ((derivation-inputs
+              (vector->list
+               (assoc-ref build-details "derivation-inputs"))))
+         (unless (null? derivation-inputs)
+           (display "\ninputs:\n")
+           (for-each
+            (lambda (derivation-input-details)
+              (simple-format #t " - ~A:\n"
+                             (assoc-ref derivation-input-details "output"))
+              (for-each (lambda (output-build)
+                          (simple-format
+                           #t
+                           "   - ~A: ~A\n"
+                           (assoc-ref output-build "uuid")
+                           (or (assoc-ref output-build "result")
+                               "unknown")))
+                        (vector->list
+                         (assoc-ref derivation-input-details "builds"))))
+            derivation-inputs)))
+
+       (let ((setup-failures
+              (vector->list
+               (assoc-ref build-details "setup-failures"))))
+         (unless (null? setup-failures)
+           (display "\nsetup failures:\n")
+           (for-each
+            (lambda (setup-failure)
+              (simple-format #t "  - agent:          ~A
     failure reason: ~A
 "
-                               (assq-ref setup-failure 'agent-id)
-                               (assq-ref setup-failure 'failure-reason))
-                (when (string=? (assq-ref setup-failure 'failure-reason)
-                                "missing_inputs")
-                  (simple-format #t "    missing inputs:\n")
-                  (for-each (lambda (missing-input)
-                              (simple-format #t
-                                             "     - ~A\n"
-                                             missing-input)
-                              (let ((builds-for-missing-input
-                                     (datastore-list-builds-for-output
-                                      datastore
-                                      missing-input)))
-                                (for-each
-                                 (lambda (missing-input-build)
-                                   (simple-format
-                                    #t
-                                    "        - ~A~A\n"
-                                    (assq-ref missing-input-build 'uuid)
-                                    (if (= 1 (assq-ref missing-input-build
-                                                       'processed))
-                                        " (finished)"
-                                        "")))
-                                 builds-for-missing-input)))
-                            (datastore-list-setup-failure-missing-inputs
-                             datastore
-                             (assq-ref setup-failure 'id)))
-                  (newline)))
-              setup-failures))))
+                             (assoc-ref setup-failure "agent-id")
+                             (assoc-ref setup-failure "failure-reason"))
+              (when (string=? (assoc-ref setup-failure "failure-reason")
+                              "missing_inputs")
+                (simple-format #t "    missing inputs:\n")
+                (for-each (lambda (missing-input)
+                            (simple-format #t
+                                           "     - ~A\n"
+                                           missing-input)
+                            (for-each
+                             (lambda (missing-input-build)
+                               (simple-format
+                                #t
+                                "        - ~A~A\n"
+                                (assoc-ref missing-input-build "uuid")
+                                (if (= 1 (assoc-ref missing-input-build
+                                                    "processed"))
+                                    " (finished)"
+                                    "")))
+                             (assoc-ref missing-input "builds")))
+                          (vector->list
+                           (assoc-ref setup-failure "missing-inputs")))
+                (newline)))
+            setup-failures))))
 
-       (define (output? s)
-         (string-prefix? "/gnu/store/" s))
-
-       (match (assq-ref opts 'arguments)
-         (((? output? output))
-          (for-each display-build
-                    (datastore-list-builds-for-output datastore output)))
-         ((build-id)
-          (match (datastore-find-build datastore build-id)
-            (#f (display "no build found\n"))
-            (build-details
-             (display-build `((uuid . ,build-id)
-                              ,@build-details)))))))))
+     (match (assq-ref opts 'arguments)
+       ((build-id)
+        (let ((response (request-build-details
+                         (assq-ref opts 'coordinator)
+                         build-id)))
+          (display-build `(("uuid" . ,build-id)
+                           ,@response)))))))
   (("build" rest ...)
    (let ((opts (parse-options (append %build-options
                                       %base-options)
                               (append %build-option-defaults
                                       %base-option-defaults)
                               rest)))
-
      (match (assq-ref opts 'arguments)
        ((derivation-file)
-        (let ((datastore
-               (database-uri->datastore
-                (assq-ref opts 'database))))
-
-          (when (assq-ref opts 'ignore-if-build-for-derivation-exists)
-            (let ((builds-for-derivation
-                   (datastore-list-builds-for-derivation datastore
-                                                         derivation-file)))
-              (unless (null? builds-for-derivation)
-                (simple-format #t "there are already ~A builds for ~A, skipping\n"
-                               (length builds-for-derivation)
-                               derivation-file)
-                (exit 0))))
-
-          (unless (file-exists? derivation-file)
-            (substitute-derivation derivation-file
-                                   #:substitute-urls
-                                   (assq-ref opts 'derivation-substitute-urls)))
-
-          (let ((derivation (read-derivation-from-file derivation-file)))
-
-            (when (assq-ref opts 'ignore-if-build-for-outputs-exists)
-              (for-each
-               (match-lambda
-                 ((name . derivation-output)
-                  (let ((builds-for-output
-                         (datastore-list-builds-for-output
-                          datastore
-                          (derivation-output-path derivation-output))))
-
-                    (unless (null? builds-for-output)
-                      (simple-format
-                       #t "there are already ~A builds for ~A, skipping\n"
-                       (length builds-for-output)
-                       (derivation-output-path derivation-output))
-                      (exit 0)))))
-               (derivation-outputs derivation)))
-
-            (let ((uuid (submit-build
-                         (make-build-coordinator
-                          #:datastore datastore)
-                         derivation
-                         #:priority (assq-ref opts 'priority)
-                         #:defer-allocation? (assq-ref opts 'defer-allocation)
-                         #:ensure-all-related-derivation-outputs-have-builds?
-                         (assq-ref
-                          opts
+        (let ((response
+               (send-submit-build-request
+                (assq-ref opts 'coordinator)
+                derivation-file
+                (assq-ref opts 'derivation-substitute-urls)
+                #f                 ; TODO requested uuid
+                (assq-ref opts 'priority)
+                (assq-ref opts 'ignore-if-build-for-derivation-exists)
+                (assq-ref opts 'ignore-if-build-for-outputs-exists)
+                (assq-ref opts
                           'ensure-all-related-derivation-outputs-have-builds))))
-              (simple-format #t "build submitted as ~A\n" uuid))))))))
+          (let ((no-build-submitted-response
+                 (assoc-ref response "no-build-submitted")))
+            (if no-build-submitted-response
+                (simple-format #t "skipped: ~A\n"
+                               no-build-submitted-response)
+                (simple-format #t "build submitted as ~A\n"
+                               (assoc-ref response "build-submitted")))))))))
   (("agent" "new" rest ...)
    (let ((opts (parse-options (append %agent-options
+                                      %client-options
                                       %base-options)
-                              %base-option-defaults
+                              (append %client-option-defaults
+                                      %base-option-defaults)
                               rest)))
-     (let ((uuid (new-agent (database-uri->datastore
-                             (assq-ref opts 'database))
-                            #:requested-uuid (assq-ref opts 'uuid)
-                            #:description (assq-ref opts 'description))))
-       (simple-format #t "agent created as as ~A\n" uuid))))
-  (("agent" id "password" "new" rest ...)
+     (let ((response (send-create-agent-request
+                      (assq-ref opts 'coordinator)
+                      #:requested-uuid (assq-ref opts 'uuid)
+                      #:description (assq-ref opts 'description))))
+       (simple-format #t "agent created as as ~A\n"
+                      (assoc-ref response "agent-id")))))
+  (("agent" agent-id "password" "new" rest ...)
    (let ((opts (parse-options %base-options
                               %base-option-defaults
                               rest)))
-     (let ((password (new-agent-password
-                      (database-uri->datastore
-                       (assq-ref opts 'database))
-                      #:agent id)))
-       (simple-format #t "new password: ~A\n" password))))
+     (let ((response (send-create-agent-password-request
+                      (assq-ref opts 'coordinator)
+                      agent-id)))
+       (simple-format #t "new password: ~A\n"
+                      (assoc-ref response "new-password")))))
   (("agent" "list" rest ...)
    (let ((opts (parse-options %base-options %base-option-defaults rest)))
      (for-each (lambda (agent)
                  (simple-format
                   #t "~A: ~A\n"
-                  (assq-ref agent 'uuid)
-                  (or (assq-ref agent 'description)
+                  (assoc-ref agent "uuid")
+                  (or (assoc-ref agent "description")
                       "(no description)")))
-               (datastore-list-agents
-                (database-uri->datastore
-                 (assq-ref opts 'database))))))
+               (vector->list
+                (assoc-ref
+                 (request-agents-list (assq-ref opts 'coordinator))
+                 "agents")))))
   ((arguments ...)
    (let* ((opts (parse-options (append %service-options
                                        %base-options)
@@ -447,6 +439,14 @@ processed?:      ~A
                          (assq-ref opts 'secret-key-base)
                          build-coordinator
                          chunked-request-channel)))))))
+              (client-communication-thunk
+               (let ((client-communication-uri
+                      (string->uri (assq-ref opts 'client-communication))))
+                 (lambda ()
+                   (start-client-request-server (assq-ref opts 'secret-key-base)
+                                                (uri-host client-communication-uri)
+                                                (uri-port client-communication-uri)
+                                                build-coordinator)))))
 
          (start-hook-processing-thread build-coordinator)
          (trigger-build-allocation build-coordinator)
@@ -457,6 +457,7 @@ processed?:      ~A
               (run-fibers
                (lambda ()
                  (agent-communication-thunk)
+                 (client-communication-thunk)
 
                  (wait finished?))))
             finished?)))))))