Add support for sending/receiving build results

1 files changed, 36 insertions, 0 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index b42b5e0..97cffdf 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -42,6 +42,7 @@
   #:export (http-agent-messaging-start-server
 
             submit-status
+            submit-build-result
             submit-output
             fetch-builds-for-agent))
 
@@ -165,6 +166,18 @@ port. Also, the port used can be changed by passing the --port option.\n"
            (render-json
             "access denied"
             #:code 403)))
+      (('PUT "build" uuid)
+       (let ((agent-id-for-build
+              (datastore-agent-for-build datastore uuid)))
+         (if (authenticated? agent-id-for-build request)
+             (begin
+               (handle-build-result datastore agent-id-for-build uuid
+                                    (json-string->scm (utf8->string body)))
+               (render-json
+                "message received"))
+             (render-json
+              "access denied"
+              #:code 403))))
       (('PUT "build" uuid "output" output-name)
        (let ((agent-id-for-build
               (datastore-agent-for-build datastore uuid)))
@@ -286,6 +299,29 @@ port. Also, the port used can be changed by passing the --port option.\n"
           (values response
                   body))))))
 
+(define (submit-build-result coordinator-uri agent-uuid password
+                             build-id result)
+  (define auth-value
+    (string-append
+     "Basic "
+     (base64-encode
+      (string->utf8
+       (string-append agent-uuid ":" password)))))
+
+  (define uri
+    (coordinator-uri-for-path
+     coordinator-uri
+     (string-append "/build/" build-id)))
+
+  (let-values (((response body)
+                (http-request
+                 uri
+                 #:method 'PUT                        ; TODO Should be PATCH
+                 #:body (scm->json-string result)
+                 #:headers
+                 `((Authorization . ,auth-value)))))
+    (json-string->scm (utf8->string body))))
+
 (define (fetch-builds-for-agent coordinator-uri agent-uuid password)
   (define auth-value
     (string-append