From 27c7e0dfe269627372100870b54a0381b6f26d03 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Thu, 9 Apr 2020 21:35:15 +0100
Subject: Support creating agents

By running guix-build-coordinator agent new
---
 scripts/guix-build-coordinator.in | 79 +++++++++++++++++++++++++++------------
 1 file changed, 56 insertions(+), 23 deletions(-)

(limited to 'scripts')

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))))
 
-- 
cgit v1.2.3