diff options
| -rw-r--r-- | guix-build-coordinator/coordinator.scm | 15 | ||||
| -rw-r--r-- | guix-build-coordinator/datastore.scm | 3 | ||||
| -rw-r--r-- | guix-build-coordinator/datastore/abstract.scm | 4 | ||||
| -rw-r--r-- | guix-build-coordinator/datastore/sqlite.scm | 29 | ||||
| -rw-r--r-- | scripts/guix-build-coordinator.in | 79 |
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)))) |