Implement more of an agent sending a status update

3 files changed, 138 insertions, 3 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 0376a55..7c36c02 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -22,13 +22,18 @@
   #:use-module (ice-9 match)
   #:use-module (system repl error-handling)
   #:use-module (fibers web server)
+  #:use-module (rnrs bytevectors)
   #:use-module (json)
   #:use-module (web http)
+  #:use-module (web client)
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web uri)
+  #:use-module (guix base64)
   #:use-module (guix-build-coordinator datastore)
-  #:export (http-agent-messaging-start-server))
+  #:export (http-agent-messaging-start-server
+
+            submit-status))
 
 (define (http-agent-messaging-start-server port host secret-key-base
                                            datastore)
@@ -82,6 +87,23 @@ port. Also, the port used can be changed by passing the --port option.\n"
                     body
                     secret-key-base
                     datastore)
+  (define (authenticated? uuid request)
+    (let* ((authorization-base64
+            (match (assq-ref (request-headers request)
+                             'authorization)
+              (('basic . s) s)))
+           (authorization
+            (utf8->string
+             (base64-decode authorization-base64))))
+      (match (string-split authorization #\:)
+        ((auth-uuid auth-password)
+         (and
+          (string=? auth-uuid uuid)
+          (datastore-agent-password-exists? datastore
+                                            uuid
+                                            auth-password)))
+        (_ #f))))
+
   (define (controller-thunk)
     (match method-and-path-components
       (('GET "agent" uuid)
@@ -94,8 +116,12 @@ port. Also, the port used can be changed by passing the --port option.\n"
               (simple-format #f "no agent found with id: ~A"
                              uuid)
               #:code 404))))
-      (('PATCH "agent" uuid)
-       (no-content))
+      (('PUT "agent" uuid)
+       (if (authenticated? uuid request)
+           (no-content)
+           (render-json
+            "access denied"
+            #:code 403)))
       (_
        (render-json
         "not-found"
@@ -108,3 +134,41 @@ port. Also, the port used can be changed by passing the --port option.\n"
                   (render-json
                    `((error . ,(simple-format #f "~A" args)))
                    #:code 500))))
+
+(define (coordinator-uri-for-path base-uri-string agent-path)
+  (let* ((base-uri (string->uri base-uri-string))
+         (scheme (uri-scheme base-uri))
+         (host   (uri-host base-uri))
+         (port   (uri-port base-uri))
+         (path   (uri-path base-uri)))
+    (build-uri scheme
+               #:host host
+               #:port port
+               #:path
+               (string-append
+                path
+                (if (string-suffix? path "/")
+                    agent-path
+                    (string-drop agent-path 1))))))
+
+(define (submit-status coordinator-uri agent-uuid password
+                       status)
+  (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)))
+
+  (http-request
+   uri
+   #:method 'PUT                        ; TODO Should be PATCH
+   #:body (scm->json-string
+           `((status . ,status)))
+   #:headers
+   `((Authorization . ,auth-value))))
diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index e69de29..e33eead 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -0,0 +1,27 @@
+;;; 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)
+  #:use-module (guix-build-coordinator agent-messaging http)
+  #:export (run-agent))
+
+(define (run-agent uuid coordinator-uri password)
+  (submit-status coordinator-uri uuid password
+                 'idle))
diff --git a/scripts/guix-build-coordinator-agent.in b/scripts/guix-build-coordinator-agent.in
index e79f218..eff66e4 100644
--- a/scripts/guix-build-coordinator-agent.in
+++ b/scripts/guix-build-coordinator-agent.in
@@ -22,3 +22,47 @@
 ;;; along with the guix-data-service.  If not, see
 ;;; <http://www.gnu.org/licenses/>.
 
+(use-modules (srfi srfi-1)
+             (srfi srfi-37)
+             (guix-build-coordinator agent))
+
+(define %options
+  ;; Specifications of the command-line options
+  (list (option '("coordinator") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'coordinator
+                              arg
+                              result)))
+        (option '("uuid") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'uuid
+                              arg
+                              result)))
+        (option '("password") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'password
+                              arg
+                              result)))))
+
+(define %option-defaults
+  ;; Alist of default option values
+  `((coordinator . "http://localhost:8745")))
+
+(define (parse-options options defaults args)
+  (args-fold
+   args %options
+   (lambda (opt name arg result)
+     (error "unrecognized option" name))
+   (lambda (arg result)
+     (error "unrecognized argument" arg))
+   %option-defaults))
+
+(setvbuf (current-output-port) 'line)
+(setvbuf (current-error-port) 'line)
+
+(let ((opts (parse-options %options
+                           %option-defaults
+                           (cdr (program-arguments)))))
+  (run-agent (assq-ref opts 'uuid)
+             (assq-ref opts 'coordinator)
+             (assq-ref opts 'password)))