Support creating agents

By running guix-build-coordinator agent new

5 files changed, 103 insertions, 27 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index a7222f0..4ede53a 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -22,7 +22,8 @@
   #:use-module (guix derivations)
   #:use-module (guix-build-coordinator utils)
   #:use-module (guix-build-coordinator datastore)
-  #:export (submit-build))
+  #:export (submit-build
+            new-agent))
 
 (define* (submit-build datastore derivation-file
                        #:key
@@ -41,3 +42,15 @@
                            priority)
 
     uuid))
+
+(define* (new-agent datastore
+                    #:key
+                    requested-uuid
+                    description)
+  (let ((uuid (or requested-uuid
+                  (random-v4-uuid))))
+    (datastore-new-agent datastore
+                         uuid
+                         description)
+
+    uuid))
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
index 4a33b60..796f843 100644
--- a/guix-build-coordinator/datastore.scm
+++ b/guix-build-coordinator/datastore.scm
@@ -5,7 +5,8 @@
   #:use-module (guix-build-coordinator datastore sqlite)
   ;; #:use-module (guix-build-coordinator datastore postgresql)
   #:re-export (datastore-store-derivation
-               datastore-store-build)
+               datastore-store-build
+               datastore-new-agent)
   #:export (database-uri->datastore))
 
 (define (database-uri->datastore database)
diff --git a/guix-build-coordinator/datastore/abstract.scm b/guix-build-coordinator/datastore/abstract.scm
index 307505b..6f684d0 100644
--- a/guix-build-coordinator/datastore/abstract.scm
+++ b/guix-build-coordinator/datastore/abstract.scm
@@ -3,10 +3,12 @@
   #:export (<abstract-datastore>
             datastore-update
             datastore-store-derivation
-            datastore-store-build))
+            datastore-store-build
+            datastore-new-agent))
 
 (define-class <abstract-datastore> ())
 
 (define-generic datastore-store-derivation)
 (define-generic datastore-store-build)
+(define-generic datastore-new-agent)
 (define-generic datastore-update)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index bc6fd0d..d9ce272 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -11,7 +11,8 @@
   #:export (sqlite-datastore
             datastore-update
             datastore-store-derivation
-            datastore-store-build))
+            datastore-store-build
+            datastore-new-agent))
 
 (define-class <sqlite-datastore> (<abstract-datastore>)
   database-file
@@ -39,6 +40,16 @@
 
     datastore))
 
+(define-method (datastore-new-agent
+                (datastore <sqlite-datastore>)
+                uuid
+                description)
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-thread-channel)
+   (lambda (db)
+     (insert-agent db uuid description)))
+  #t)
+
 (define-method (datastore-store-derivation
                 (datastore <sqlite-datastore>)
                 derivation)
@@ -230,3 +241,19 @@ VALUES (:uuid, :derivation_name, :priority)")))
 
     (sqlite-step statement)
     (sqlite-reset statement)))
+
+(define (insert-agent db uuid description)
+  (let ((statement
+         (sqlite-prepare
+          db
+          "
+INSERT INTO agents (id, description)
+VALUES (:id, :description)")))
+
+    (sqlite-bind-arguments
+     statement
+     #:id uuid
+     #:description description)
+
+    (sqlite-step statement)
+    (sqlite-reset statement)))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 5bf3d31..298c9fe 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -30,14 +30,9 @@
              (guix-build-coordinator coordinator)
              (guix-build-coordinator agent-messaging http))
 
-(define %options
+(define %base-options
   ;; Specifications of the command-line options
-  (list (option '("pid-file") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'pid-file
-                              arg
-                              result)))
-        (option '("secret-key-base-file") #t #f
+  (list (option '("secret-key-base-file") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'secret-key-base
                               (string-trim-right
@@ -51,21 +46,11 @@
         (option '("update-database") #f #f
                 (lambda (opt name _ result)
                   (alist-cons 'update-database #t result)))
-        (option '("port") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'port
-                              (string->number arg)
-                              (alist-delete 'port result))))
-        (option '("host") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'host
-                              arg
-                              (alist-delete 'host result))))
         (option '("show-error-details") #f #f
                 (lambda (opt name _ result)
                   (alist-cons 'show-error-details #t result)))))
 
-(define %default-options
+(define %base-option-defaults
   ;; Alist of default option values
   `((update-database                      . #f)
     (database . "sqlite://guix_build_coordinator.db")
@@ -77,9 +62,43 @@
           ("" #f)
           (_ #t)))))
 
-(define (parse-options args)
+(define %service-options
+  (list (option '("pid-file") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'pid-file
+                              arg
+                              result)))
+        (option '("port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port
+                              (string->number arg)
+                              (alist-delete 'port result))))
+        (option '("host") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'host
+                              arg
+                              (alist-delete 'host result))))))
+
+(define %service-option-defaults
+  ;; Alist of default option values
+  `((port                                 . 8745)
+    (host                                 . "0.0.0.0")))
+
+(define %agent-options
+  (list (option '("uuid") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'uuid
+                              arg
+                              result)))
+        (option '("description") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'description
+                              arg
+                              result)))))
+
+(define (parse-options options defaults args)
   (args-fold
-   args %options
+   args options
    (lambda (opt name arg result)
      (error "unrecognized option" name))
    (lambda (arg result)
@@ -89,14 +108,14 @@
             (or (assoc-ref result 'arguments)
                 '()))
       (alist-delete 'arguments result)))
-   %default-options))
+   defaults))
 
 (setvbuf (current-output-port) 'line)
 (setvbuf (current-error-port) 'line)
 
 (match (cdr (program-arguments))
   (("build" rest ...)
-   (let ((opts (parse-options rest)))
+   (let ((opts (parse-options %base-options %base-option-defaults rest)))
 
      (match (assq-ref opts 'arguments)
        ((derivation-file)
@@ -106,8 +125,22 @@
                       (assq-ref opts 'database))
                      derivation-file)))
           (simple-format #t "build submitted as ~A\n" uuid))))))
+  (("agent" "new" rest ...)
+   (let ((opts (parse-options (append %agent-options
+                                      %base-options)
+                              %base-option-defaults
+                              rest)))
+     (let ((uuid (new-agent (database-uri->datastore
+                             (assq-ref opts 'database))
+                            #:requested-uuid (assq-ref opts 'uuid)
+                            #:description (assq-ref opts 'description))))
+       (simple-format #t "agent created as as ~A\n" uuid))))
   ((arguments ...)
-   (let* ((opts (parse-options arguments))
+   (let* ((opts (parse-options (append %service-options
+                                       %base-options)
+                               (append %service-option-defaults
+                                       %base-option-defaults)
+                               arguments))
           (datastore (database-uri->datastore
                       (assq-ref opts 'database))))