From b33c9b250ab0aaa21107370a1caca195b71533a7 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 16 Jan 2021 14:48:13 +0000 Subject: 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. --- guix-build-coordinator/agent-messaging/local.scm | 156 +++++++++++++++++++++++ 1 file changed, 156 insertions(+) create mode 100644 guix-build-coordinator/agent-messaging/local.scm (limited to 'guix-build-coordinator/agent-messaging') 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 +;;; +;;; 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 +;;; . + +(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 () + (build-coordinator #:init-keyword #:build-coordinator) + (agent-id #:init-keyword #:agent-id)) + +(define (make-local-agent-interface build-coordinator agent-id) + (make + #:build-coordinator build-coordinator + #:agent-id agent-id)) + +(define (default-log level . components) + (apply log-msg level components)) + +(define-method (submit-status + (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 ) + . + 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 ) + . + 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 ) + . + 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 ) + . + 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 ) + . + 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 ) + . + 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)) -- cgit v1.2.3