Refactor some of the HTTP requests

To reduce the code duplication.

1 files changed, 49 insertions, 78 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 52856e1..a3a56b5 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -330,8 +330,9 @@ port. Also, the port used can be changed by passing the --port option.\n"
                     agent-path
                     (string-drop agent-path 1))))))
 
-(define (submit-status coordinator-uri agent-uuid password
-                       status)
+(define* (coordinator-http-request coordinator-uri agent-uuid password
+                                   path
+                                   #:key method body (headers '()))
   (define auth-value
     (string-append
      "Basic "
@@ -340,19 +341,38 @@ port. Also, the port used can be changed by passing the --port option.\n"
        (string-append agent-uuid ":" password)))))
 
   (define uri
-    (coordinator-uri-for-path
-     coordinator-uri
-     (string-append "/agent/" agent-uuid)))
+    (coordinator-uri-for-path coordinator-uri
+                              path))
 
   (let-values (((response body)
-                (http-request
-                 uri
-                 #:method 'PUT                        ; TODO Should be PATCH
-                 #:body (scm->json-string
-                         `((status . ,status)))
-                 #:headers
-                 `((Authorization . ,auth-value)))))
-    (json-string->scm (utf8->string body))))
+                (http-request uri
+                              #:method method
+                              #:body (scm->json-string body)
+                              #:decode-body? #f
+                              #:headers
+                              `((Authorization . ,auth-value)
+                                ,@headers))))
+    (if (>= (response-code response) 400)
+        (error (catch #t
+                 (lambda ()
+                   (json-string->scm (utf8->string body)))
+                 (lambda (key . args)
+                   (simple-format
+                    (current-error-port)
+                    "error decoding body ~A ~A\n"
+                    key args)
+                   #f)))
+        (values
+         (json-string->scm (utf8->string body))
+         response))))
+
+(define (submit-status coordinator-uri agent-uuid password
+                       status)
+  (coordinator-http-request
+   coordinator-uri agent-uuid password
+   (string-append "/agent/" agent-uuid)
+   #:method 'PUT                        ; TODO Should be PATCH
+   #:body `((status . ,status))))
 
 (define (submit-output coordinator-uri agent-uuid password
                        build-id output-name file)
@@ -409,73 +429,24 @@ port. Also, the port used can be changed by passing the --port option.\n"
 
 (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)))))
-    (let ((message
-           (json-string->scm (utf8->string body))))
-      (if (>= (response-code response) 400)
-          (error message)
-          message))))
+  (coordinator-http-request
+   coordinator-uri agent-uuid password
+   (string-append "/build/" build-id)
+   #:method 'PUT                        ; TODO Should be PATCH
+   #:body result))
 
 (define (report-setup-failure coordinator-uri agent-uuid password
                               build-id report)
-  (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 "/report-setup-failure")))
-
-  (let-values (((response body)
-                (http-request
-                 uri
-                 #:method 'POST
-                 #:body (scm->json-string report)
-                 #:headers
-                 `((Authorization . ,auth-value)))))
-    (json-string->scm (utf8->string body))))
+  (coordinator-http-request
+   coordinator-uri agent-uuid password
+   (string-append "/build/" build-id "/report-setup-failure")
+   #:method 'POST
+   #:body report))
 
 (define (fetch-builds-for-agent coordinator-uri agent-uuid password)
-  (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 "/agent/" agent-uuid "/fetch-builds")))
-
-  (let-values (((response body)
-                (http-request
-                 uri
-                 #:method 'POST
-                 #:headers
-                 `((Authorization . ,auth-value)))))
-    (vector->list
-     (assoc-ref (json-string->scm (utf8->string body))
-                "builds"))))
+  (vector->list
+   (assoc-ref (coordinator-http-request
+               coordinator-uri agent-uuid password
+               (string-append "/agent/" agent-uuid "/fetch-builds")
+               #:method 'POST)
+              "builds")))