Start implementing the HTTP agent messaging features

1 files changed, 100 insertions, 0 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
new file mode 100644
index 0000000..d070ac1
--- /dev/null
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -0,0 +1,100 @@
+;;; 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 agent-messaging http)
+  #:use-module (ice-9 match)
+  #:use-module (system repl error-handling)
+  #:use-module (fibers web server)
+  #:use-module (json)
+  #:use-module (web http)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (http-agent-messaging-start-server))
+
+(define (http-agent-messaging-start-server port host secret-key-base
+                                           datastore)
+  (call-with-error-handling
+   (lambda ()
+     (run-server
+      (lambda (request body)
+        (format #f "~a ~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)))
+      #:host host
+      #:port port))
+   #:on-error 'backtrace
+   #:post-error (lambda (key . args)
+                  (when (eq? key 'system-error)
+                    (match args
+                      (("bind" "~A" ("Address already in use") _)
+                       (simple-format
+                        (current-error-port)
+                        "\n
+error: guix-build-coordinator could not start, as it could not bind to port ~A
+
+Check if it's already running, or whether another process is using that
+port. Also, the port used can be changed by passing the --port option.\n"
+                        port)))))))
+
+(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 (no-content)
+  (list (build-response #:code 204)
+        ""))
+
+(define (controller request
+                    method-and-path-components
+                    body
+                    secret-key-base)
+  (define (controller-thunk)
+    (match method-and-path-components
+      (('GET "agent" uuid)
+       (render-json
+        `((agent . ,uuid))))
+      (('PATCH "agent" uuid)
+       (no-content))
+      (_
+       (render-json
+        "not-found"
+        #:code 404))))
+
+  (call-with-error-handling
+   controller-thunk
+   #:on-error 'backtrace
+   #:post-error (lambda args
+                  (render-json
+                   `((error . ,(simple-format #f "~A" args)))
+                   #:code 500))))