diff options
Diffstat (limited to 'guix-build-coordinator/agent-messaging')
| -rw-r--r-- | guix-build-coordinator/agent-messaging/http.scm | 51 | ||||
| -rw-r--r-- | guix-build-coordinator/agent-messaging/http/server.scm | 28 |
2 files changed, 77 insertions, 2 deletions
diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm index 1f2df0a..752f354 100644 --- a/guix-build-coordinator/agent-messaging/http.scm +++ b/guix-build-coordinator/agent-messaging/http.scm @@ -47,6 +47,8 @@ #:use-module (guix-build-coordinator agent-messaging abstract) #:export (make-http-agent-interface + fetch-session-credentials + submit-status submit-log-file submit-build-result @@ -68,7 +70,8 @@ #:agent-uuid agent-uuid #:password password)) -(define (coordinator-uri-for-path base-uri-string agent-path) +(define* (coordinator-uri-for-path base-uri-string agent-path + #:key query) (let* ((base-uri (string->uri base-uri-string)) (scheme (uri-scheme base-uri)) (host (uri-host base-uri)) @@ -82,7 +85,8 @@ path (if (string-suffix? path "/") agent-path - (string-drop agent-path 1)))))) + (string-drop agent-path 1))) + #:query query))) (define (with-request-mutex thunk) (if (running-on-the-hurd?) @@ -184,6 +188,49 @@ #:delay 10 #:ignore agent-error-from-coordinator?)) +(define* (fetch-session-credentials coordinator + name + token + #:key (log default-log)) + (define method 'POST) + (define path "/agent/fetch-session-credentials") + (define uri (coordinator-uri-for-path coordinator path + #:query + (simple-format #f "name=~A&token=~A" + name token))) + + (let-values (((response body) + (http-request uri + #:method method + #:decode-body? #f))) + (let ((code (response-code response))) + (cond + ((eq? code 400) + (and=> (coordinator-handle-failed-request log + method + path + response + body) + (lambda (error) + (raise-exception + (make-agent-error-from-coordinator + (assoc-ref error "error")))))) + + ((>= (response-code response) 400) + (let ((body + (coordinator-handle-failed-request log + method + path + response + body))) + (raise-exception + (make-exception-with-message + body)))) + (else + (values + (json-string->scm (utf8->string body)) + response)))))) + (define-method (submit-status (interface <http-agent-interface>) . diff --git a/guix-build-coordinator/agent-messaging/http/server.scm b/guix-build-coordinator/agent-messaging/http/server.scm index 338bab6..da602ea 100644 --- a/guix-build-coordinator/agent-messaging/http/server.scm +++ b/guix-build-coordinator/agent-messaging/http/server.scm @@ -241,6 +241,34 @@ port. Also, the port used can be changed by passing the --port option.\n" (render-json '(("error" . "access denied")) #:code 403))) + (('POST "agent" "fetch-session-credentials") + (let* ((query-parameters (request-query-parameters request)) + (name (assq-ref query-parameters 'name)) + (token (assq-ref query-parameters 'token))) + (if (and (string? name) + (string? token)) + (let ((agent-uuid (or (datastore-find-agent-by-name + datastore + name) + (new-agent datastore + #:name name)))) + (if (datastore-dynamic-auth-token-exists? datastore token) + (let ((password + (match (datastore-agent-list-passwords datastore + agent-uuid) + (() + (new-agent-password datastore #:agent agent-uuid)) + ((password . rest) + password)))) + (render-json + `((id . ,agent-uuid) + (password . ,password)))) + (render-json + '(("error" . "token not recognised")) + #:code 403))) + (render-json + '(("error" . "access denied")) + #:code 403)))) (('POST "agent" uuid "fetch-builds") (if (authenticated? uuid request) (let* ((json-body (json-string->scm (utf8->string body))) |