Add a new dynamic authentication approach

This avoids the need to create agents upfront, which could be useful when
creating many childhurd VMs or using scheduling tools to dynamically run
agents.

6 files changed, 206 insertions, 6 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)))
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 550b054..664b9aa 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -29,6 +29,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (json)
   #:use-module (logging logger)
+  #:use-module (gcrypt random)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (web request)
@@ -52,6 +53,7 @@
             request-failed-builds-with-blocking-count-list
             send-create-agent-request
             send-create-agent-password-request
+            send-create-dynamic-auth-token-request
             send-replace-agent-tags-request))
 
 (define (start-client-request-server secret-key-base
@@ -217,6 +219,11 @@
                     #:description (assoc-ref body "description"))))
          (render-json
           `((agent-id . ,uuid)))))
+      (('POST "dynamic-auth-tokens")
+       (let ((token (random-token)))
+         (datastore-insert-dynamic-auth-token datastore token)
+         (render-json
+          `((token . ,token)))))
       (('GET "agent" agent-id)
        (let ((agent-details (datastore-find-agent datastore agent-id)))
          (render-json
@@ -631,6 +638,11 @@
                 'POST
                 (string-append "/agent/" agent-id "/passwords")))
 
+(define (send-create-dynamic-auth-token-request coordinator-uri)
+  (send-request coordinator-uri
+                'POST
+                "/dynamic-auth-tokens"))
+
 (define (send-replace-agent-tags-request coordinator-uri
                                          agent-id
                                          tags)
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index f9f9bf8..bae5d11 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -390,11 +390,13 @@
 (define* (new-agent datastore
                     #:key
                     requested-uuid
+                    name
                     description)
   (let ((uuid (or requested-uuid
                   (random-v4-uuid))))
     (datastore-new-agent datastore
                          uuid
+                         name
                          description)
 
     uuid))
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
index 24b9bbb..0f072ac 100644
--- a/guix-build-coordinator/datastore.scm
+++ b/guix-build-coordinator/datastore.scm
@@ -19,6 +19,9 @@
 (re-export datastore-new-agent)
 (re-export datastore-list-agents)
 (re-export datastore-find-agent)
+(re-export datastore-find-agent-by-name)
+(re-export datastore-insert-dynamic-auth-token)
+(re-export datastore-dynamic-auth-token-exists?)
 (re-export datastore-fetch-agent-tags)
 (re-export datastore-count-build-results)
 (re-export datastore-insert-build-result)
@@ -41,6 +44,7 @@
 (re-export datastore-list-setup-failure-missing-inputs)
 (re-export datastore-new-agent-password)
 (re-export datastore-agent-password-exists?)
+(re-export datastore-agent-list-passwords)
 (re-export datastore-replace-agent-tags)
 (re-export datastore-count-builds)
 (re-export datastore-for-each-build)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 3a110e5..898a148 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -46,6 +46,9 @@
             datastore-new-agent
             datastore-list-agents
             datastore-find-agent
+            datastore-find-agent-by-name
+            datastore-insert-dynamic-auth-token
+            datastore-dynamic-auth-token-exists?
             datastore-fetch-agent-tags
             datastore-store-build-start
             datastore-find-build-starts
@@ -64,6 +67,7 @@
             datastore-list-builds-for-output-and-system
             datastore-new-agent-password
             datastore-agent-password-exists?
+            datastore-agent-list-passwords
             datastore-replace-agent-tags
             datastore-list-processed-builds
             datastore-list-unprocessed-builds
@@ -378,6 +382,82 @@ SELECT description FROM agents WHERE id = :id"
 
          result)))))
 
+(define-method (datastore-find-agent-by-name
+                (datastore <sqlite-datastore>)
+                name)
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-reader-thread-channel)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT id FROM agents WHERE name = :name"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:name name)
+
+       (let ((result
+              (match (sqlite-map
+                      (match-lambda
+                        (#(id) id))
+                      statement)
+                (() #f)
+                ((agent) agent))))
+         (sqlite-reset statement)
+
+         result)))))
+
+(define-method (datastore-insert-dynamic-auth-token
+                (datastore <sqlite-datastore>)
+                token)
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-writer-thread-channel)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+INSERT INTO dynamic_auth_tokens (token) VALUES (:token)"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:token token)
+
+       (sqlite-step statement)
+       (sqlite-reset statement)))))
+
+(define-method (datastore-dynamic-auth-token-exists?
+                (datastore <sqlite-datastore>)
+                token)
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-reader-thread-channel)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT 1 FROM dynamic_auth_tokens WHERE token = :token"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:token token)
+
+       (let ((result
+              (match (sqlite-map
+                      (match-lambda
+                        (#(1) #t))
+                      statement)
+                ((#t) #t)
+                (() #f))))
+         (sqlite-reset statement)
+
+         result)))))
+
 (define-method (datastore-fetch-agent-tags
                 (datastore <sqlite-datastore>)
                 agent-id)
@@ -416,11 +496,12 @@ WHERE agent_tags.agent_id = :agent_id"
 (define-method (datastore-new-agent
                 (datastore <sqlite-datastore>)
                 uuid
+                name
                 description)
   (call-with-worker-thread
    (slot-ref datastore 'worker-writer-thread-channel)
    (lambda (db)
-     (insert-agent db uuid description)))
+     (insert-agent db uuid name description)))
   #t)
 
 (define-method (datastore-list-agents
@@ -483,6 +564,31 @@ WHERE agent_id = :agent_id AND password = :password"
 
          result)))))
 
+(define-method (datastore-agent-list-passwords
+                (datastore <sqlite-datastore>)
+                uuid)
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-reader-thread-channel)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT password FROM agent_passwords WHERE agent_id = :agent_id"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:agent_id uuid)
+
+       (let ((result (sqlite-map
+                      (match-lambda
+                        (#(password) password))
+                      statement)))
+         (sqlite-reset statement)
+
+         result)))))
+
 (define-method (datastore-replace-agent-tags
                 (datastore <sqlite-datastore>)
                 agent-id
@@ -3097,18 +3203,19 @@ VALUES (:uuid, :derivation_name, :priority, datetime('now'), :deferred_until)"
        (sqlite-reset statement))))
   #t)
 
-(define (insert-agent db uuid description)
+(define (insert-agent db uuid name description)
   (let ((statement
          (sqlite-prepare
           db
           "
-INSERT INTO agents (id, description)
-VALUES (:id, :description)"
+INSERT INTO agents (id, name, description)
+VALUES (:id, :name, :description)"
           #:cache? #t)))
 
     (sqlite-bind-arguments
      statement
      #:id uuid
+     #:name name
      #:description description)
 
     (sqlite-step statement)