aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2021-01-16 14:48:13 +0000
committerChristopher Baines <mail@cbaines.net>2021-01-16 14:48:13 +0000
commitb33c9b250ab0aaa21107370a1caca195b71533a7 (patch)
treecc0e3816584e681251f34b0aeb40796152259491
parent8697a008ab16c2ea97279d6650affd4c771ddddc (diff)
downloadbuild-coordinator-b33c9b250ab0aaa21107370a1caca195b71533a7.tar
build-coordinator-b33c9b250ab0aaa21107370a1caca195b71533a7.tar.gz
Add local agent messaging
This is untested, but might be quite cool for running a single agent instance of the build coordinator, all in one process.
-rw-r--r--Makefile.am1
-rw-r--r--guix-build-coordinator/agent-messaging.scm1
-rw-r--r--guix-build-coordinator/agent-messaging/local.scm156
3 files changed, 158 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am
index 2036d67..ae2e48b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -8,6 +8,7 @@ bin_SCRIPTS = \
SOURCES = \
guix-build-coordinator/agent-messaging.scm \
guix-build-coordinator/agent-messaging/abstract.scm \
+ guix-build-coordinator/agent-messaging/local.scm \
guix-build-coordinator/agent-messaging/http.scm \
guix-build-coordinator/agent-messaging/http/server.scm \
guix-build-coordinator/agent.scm \
diff --git a/guix-build-coordinator/agent-messaging.scm b/guix-build-coordinator/agent-messaging.scm
index 912254b..73f1f63 100644
--- a/guix-build-coordinator/agent-messaging.scm
+++ b/guix-build-coordinator/agent-messaging.scm
@@ -20,6 +20,7 @@
(define-module (guix-build-coordinator agent-messaging)
#:use-module (oop goops)
+ #:use-module (guix-build-coordinator agent-messaging local)
#:use-module (guix-build-coordinator agent-messaging http)
#:duplicates (merge-generics))
diff --git a/guix-build-coordinator/agent-messaging/local.scm b/guix-build-coordinator/agent-messaging/local.scm
new file mode 100644
index 0000000..4a02a39
--- /dev/null
+++ b/guix-build-coordinator/agent-messaging/local.scm
@@ -0,0 +1,156 @@
+;;; Guix Build Coordinator
+;;;
+;;; Copyright © 2021 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of the guix-build-coordinator.
+;;;
+;;; The Guix Build Coordinator is free software; you can redistribute
+;;; it and/or modify it under the terms of the GNU General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; The Guix Build Coordinator is distributed in the hope that it will
+;;; be useful, but WITHOUT ANY WARRANTY; without even the implied
+;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+;;; See the GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-build-coordinator agent-messaging local)
+ #:use-module (oop goops)
+ #:use-module (logging logger)
+ #:use-module (lzlib)
+ #:use-module (guix serialization)
+ #:use-module (guix-build-coordinator datastore)
+ #:use-module (guix-build-coordinator coordinator)
+ #:use-module (guix-build-coordinator agent-messaging abstract)
+ #:export (make-local-agent-interface
+
+ submit-status
+ submit-log-file
+ submit-build-result
+ report-build-start
+ report-setup-failure
+ submit-output
+ fetch-builds-for-agent))
+
+(define-class <local-agent-interface> ()
+ (build-coordinator #:init-keyword #:build-coordinator)
+ (agent-id #:init-keyword #:agent-id))
+
+(define (make-local-agent-interface build-coordinator agent-id)
+ (make <local-agent-interface>
+ #:build-coordinator build-coordinator
+ #:agent-id agent-id))
+
+(define (default-log level . components)
+ (apply log-msg level components))
+
+(define-method (submit-status
+ (interface <local-agent-interface>)
+ .
+ args)
+ (apply
+ (lambda* (status #:key (log default-log))
+ (agent-details (build-coordinator-datastore
+ (slot-ref interface 'build-coordinator))
+ (slot-ref interface 'agent-id)))
+ args))
+
+(define-method (submit-output
+ (interface <local-agent-interface>)
+ .
+ args)
+ (apply
+ (lambda* (build-id output-name file #:key (log default-log))
+ (let* ((output-file-name
+ (build-output-file-location (build-coordinator-datastore
+ (slot-ref interface 'datastore))
+ build-id
+ output-name))
+ (tmp-output-file-name
+ (string-append output-file-name ".tmp")))
+ (when (file-exists? tmp-output-file-name)
+ (delete-file tmp-output-file-name))
+ (log 'INFO "compressing " file " -> " tmp-output-file-name)
+ (call-with-output-file tmp-output-file-name
+ (lambda (out)
+ (call-with-lzip-output-port out
+ (lambda (port)
+ (write-file file port))
+ #:level 9)
+ (close-port out)))
+
+ (rename-file tmp-output-file-name
+ output-file-name)))
+ args))
+
+(define-method (submit-log-file
+ (interface <local-agent-interface>)
+ .
+ args)
+ (apply
+ (lambda* (build-id file #:key (log default-log))
+ (define format
+ (cond
+ ((string-suffix? ".bz2" file) "bzip2")
+ ((string-suffix? ".gz" file) "gzip")
+ (else
+ (error "unsupported log format for" file))))
+
+ (let* ((output-file-name
+ (build-log-file-destination build-id format)))
+ (copy-file file
+ output-file-name)))
+ args))
+
+(define-method (submit-build-result
+ (interface <local-agent-interface>)
+ .
+ args)
+ (apply
+ (lambda* (build-id result #:key (log default-log))
+ (handle-build-result (slot-ref interface 'build-coordinator)
+ (slot-ref interface 'agent-id)
+ build-id
+ result))
+ args))
+
+(define-method (report-build-start
+ (interface <local-agent-interface>)
+ .
+ args)
+ (apply
+ (lambda* (build-id #:key (log default-log))
+ (handle-build-start-report (slot-ref interface 'build-coordinator)
+ (slot-ref interface 'agent-id)
+ build-id))
+ args))
+
+(define-method (report-setup-failure
+ (interface <local-agent-interface>)
+ .
+ args)
+ (apply
+ (lambda* (build-id report #:key (log default-log))
+ (handle-setup-failure-report
+ (slot-ref interface 'build-coordinator)
+ (slot-ref interface 'agent-id)
+ build-id
+ report))
+ args))
+
+(define-method (fetch-builds-for-agent
+ (interface <local-agent-interface>)
+ .
+ args)
+ (apply
+ (lambda* (systems target-count #:key (log default-log))
+ (fetch-builds (slot-ref interface 'build-coordinator)
+ (slot-ref interface 'agent-id)
+ systems
+ target-count
+ #f))
+ args))