diff options
author | Christopher Baines <mail@cbaines.net> | 2020-04-10 19:09:39 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2020-04-10 20:34:47 +0100 |
commit | 97876168197cbbc4780fe34582be47f153af79b4 (patch) | |
tree | 139a0c71de6bfd850e2e3102728156eccd313e56 | |
parent | 4c11476163b0ee891d23c4d6eb35420e9d087e40 (diff) | |
download | build-coordinator-97876168197cbbc4780fe34582be47f153af79b4.tar build-coordinator-97876168197cbbc4780fe34582be47f153af79b4.tar.gz |
Implement more of an agent sending a status update
-rw-r--r-- | guix-build-coordinator/agent-messaging/http.scm | 70 | ||||
-rw-r--r-- | guix-build-coordinator/agent.scm | 27 | ||||
-rw-r--r-- | scripts/guix-build-coordinator-agent.in | 44 |
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))) |