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.

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))