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.

21 files changed, 358 insertions, 18 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)
diff --git a/scripts/guix-build-coordinator-agent.in b/scripts/guix-build-coordinator-agent.in
index 895adf7..b5c0bd0 100644
--- a/scripts/guix-build-coordinator-agent.in
+++ b/scripts/guix-build-coordinator-agent.in
@@ -23,13 +23,15 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (use-modules (srfi srfi-1)
+             (srfi srfi-11)
              (srfi srfi-37)
              (ice-9 threads)
              (ice-9 textual-ports)
              ((guix config) #:prefix guix-config:)
              (guix-build-coordinator utils)
              (guix-build-coordinator agent)
-             (guix-build-coordinator agent-messaging))
+             (guix-build-coordinator agent-messaging)
+             (guix-build-coordinator agent-messaging http))
 
 (define %options
   ;; Specifications of the command-line options
@@ -43,6 +45,11 @@
                   (alist-cons 'uuid
                               arg
                               result)))
+        (option '("name") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'name
+                              arg
+                              result)))
         (option '("password") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'password
@@ -54,6 +61,17 @@
                                 (string-trim-right
                                  (call-with-input-file arg get-string-all))
                                 result)))
+        (option '("dynamic-auth-token") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'dynamic-auth-token
+                              arg
+                              result)))
+        (option '("dynamic-auth-token-file") #t #f
+                  (lambda (opt name arg result)
+                    (alist-cons 'dynamic-auth-token
+                                (string-trim-right
+                                 (call-with-input-file arg get-string-all))
+                                result)))
         (option '("max-parallel-builds") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'max-parallel-builds
@@ -117,16 +135,39 @@
 (let ((opts (parse-options %options
                            %option-defaults
                            (cdr (program-arguments)))))
-  (run-agent (assq-ref opts 'uuid)
+  (let-values
+      (((uuid coordinator-interface)
+        (cond
+         ((and (string? (assq-ref opts 'uuid))
+               (string? (assq-ref opts 'password)))
+          (values
+           (assq-ref opts 'uuid)
+           (make-http-agent-interface
+            (assq-ref opts 'coordinator)
+            (assq-ref opts 'uuid)
+            (assq-ref opts 'password))))
+         ((and (string? (assq-ref opts 'name))
+               (string? (assq-ref opts 'dynamic-auth-token)))
+          (let ((session-credentials
+                 (fetch-session-credentials (assq-ref opts 'coordinator)
+                                            (assq-ref opts 'name)
+                                            (assq-ref opts 'dynamic-auth-token))))
+            (values
+             (assoc-ref session-credentials "id")
              (make-http-agent-interface
               (assq-ref opts 'coordinator)
-              (assq-ref opts 'uuid)
-              (assq-ref opts 'password))
-             (delete-duplicates (assq-ref opts 'systems))
-             (assq-ref opts 'max-parallel-builds)
-             (or (assq-ref opts 'derivation-substitute-urls)
-                 (assq-ref opts 'substitute-urls))
-             (or (assq-ref opts 'non-derivation-substitute-urls)
-                 (assq-ref opts 'substitute-urls))
-             (assq-ref opts 'metrics-file)
-             (assq-ref opts 'max-1min-load-average)))
+              (assoc-ref session-credentials "id")
+              (assoc-ref session-credentials "password")))))
+         (else
+          (error "unknown coordinator interface")))))
+
+    (run-agent uuid
+               coordinator-interface
+               (delete-duplicates (assq-ref opts 'systems))
+               (assq-ref opts 'max-parallel-builds)
+               (or (assq-ref opts 'derivation-substitute-urls)
+                   (assq-ref opts 'substitute-urls))
+               (or (assq-ref opts 'non-derivation-substitute-urls)
+                   (assq-ref opts 'substitute-urls))
+               (assq-ref opts 'metrics-file)
+               (assq-ref opts 'max-1min-load-average))))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 4c7e208..f85a0ce 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -737,6 +737,17 @@ tags:
                 (assoc-ref
                  (request-agents-list (assq-ref opts 'coordinator))
                  "agents")))))
+  (("dynamic-auth" "create-token")
+   (let ((opts (parse-options (append %client-options
+                                      %base-options)
+                              (append %client-option-defaults
+                                      %base-option-defaults)
+                              '())))
+     (let ((token
+            (assoc-ref (send-create-dynamic-auth-token-request
+                        (assq-ref opts 'coordinator))
+                       "token")))
+       (simple-format #t "~A\n" token))))
   ((arguments ...)
    (let* ((opts (parse-options (append %service-options
                                        %base-options)
diff --git a/sqitch/pg/deploy/add_agent_names.sql b/sqitch/pg/deploy/add_agent_names.sql
new file mode 100644
index 0000000..e53c2f1
--- /dev/null
+++ b/sqitch/pg/deploy/add_agent_names.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-build-coordinator:add_agent_names to pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/deploy/add_dynamic_auth_tokens.sql b/sqitch/pg/deploy/add_dynamic_auth_tokens.sql
new file mode 100644
index 0000000..5a4022d
--- /dev/null
+++ b/sqitch/pg/deploy/add_dynamic_auth_tokens.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-build-coordinator:add_dynamic_auth_tokens to pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/revert/add_agent_names.sql b/sqitch/pg/revert/add_agent_names.sql
new file mode 100644
index 0000000..9446feb
--- /dev/null
+++ b/sqitch/pg/revert/add_agent_names.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:add_agent_names from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/revert/add_dynamic_auth_tokens.sql b/sqitch/pg/revert/add_dynamic_auth_tokens.sql
new file mode 100644
index 0000000..b061032
--- /dev/null
+++ b/sqitch/pg/revert/add_dynamic_auth_tokens.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:add_dynamic_auth_tokens from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/verify/add_agent_names.sql b/sqitch/pg/verify/add_agent_names.sql
new file mode 100644
index 0000000..9f69522
--- /dev/null
+++ b/sqitch/pg/verify/add_agent_names.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:add_agent_names on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/sqitch/pg/verify/add_dynamic_auth_tokens.sql b/sqitch/pg/verify/add_dynamic_auth_tokens.sql
new file mode 100644
index 0000000..b0b62a0
--- /dev/null
+++ b/sqitch/pg/verify/add_dynamic_auth_tokens.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:add_dynamic_auth_tokens on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index 513609c..19e2b11 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -26,3 +26,5 @@ support_build_cancelation 2020-12-11T18:25:42Z Christopher Baines <mail@cbaines.
 add_build_tags_build_id_idx 2020-12-21T13:20:54Z Christopher Baines <mail@cbaines.net> # Add an index on build_tags.build_id
 add_builds_deferred_until 2020-12-26T19:26:32Z Christopher Baines <mail@cbaines.net> # Add builds.deferred_until
 add_agent_tags 2021-01-17T11:13:23Z Christopher Baines <mail@cbaines.net> # Add tags for agents
+add_agent_names 2021-02-28T14:04:24Z Christopher Baines <mail@cbaines.net> # Add agent.names
+add_dynamic_auth_tokens 2021-02-28T15:21:24Z Christopher Baines <mail@cbaines.net> # Add dynamic_auth_tokens
diff --git a/sqitch/sqlite/deploy/add_agent_names.sql b/sqitch/sqlite/deploy/add_agent_names.sql
new file mode 100644
index 0000000..bc2ec44
--- /dev/null
+++ b/sqitch/sqlite/deploy/add_agent_names.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-build-coordinator:add_agent_names to sqlite
+
+BEGIN;
+
+ALTER TABLE agents ADD COLUMN name TEXT;
+
+COMMIT;
diff --git a/sqitch/sqlite/deploy/add_dynamic_auth_tokens.sql b/sqitch/sqlite/deploy/add_dynamic_auth_tokens.sql
new file mode 100644
index 0000000..9d50c95
--- /dev/null
+++ b/sqitch/sqlite/deploy/add_dynamic_auth_tokens.sql
@@ -0,0 +1,9 @@
+-- Deploy guix-build-coordinator:add_dynamic_auth_tokens to sqlite
+
+BEGIN;
+
+CREATE TABLE dynamic_auth_tokens (
+       token TEXT NOT NULL
+);
+
+COMMIT;
diff --git a/sqitch/sqlite/revert/add_agent_names.sql b/sqitch/sqlite/revert/add_agent_names.sql
new file mode 100644
index 0000000..5bfd09e
--- /dev/null
+++ b/sqitch/sqlite/revert/add_agent_names.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:add_agent_names from sqlite
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqlite/revert/add_dynamic_auth_tokens.sql b/sqitch/sqlite/revert/add_dynamic_auth_tokens.sql
new file mode 100644
index 0000000..8bf4e0a
--- /dev/null
+++ b/sqitch/sqlite/revert/add_dynamic_auth_tokens.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:add_dynamic_auth_tokens from sqlite
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqlite/verify/add_agent_names.sql b/sqitch/sqlite/verify/add_agent_names.sql
new file mode 100644
index 0000000..e072871
--- /dev/null
+++ b/sqitch/sqlite/verify/add_agent_names.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:add_agent_names on sqlite
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/sqitch/sqlite/verify/add_dynamic_auth_tokens.sql b/sqitch/sqlite/verify/add_dynamic_auth_tokens.sql
new file mode 100644
index 0000000..b14eba5
--- /dev/null
+++ b/sqitch/sqlite/verify/add_dynamic_auth_tokens.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:add_dynamic_auth_tokens on sqlite
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;