branch: main
commit 8c47556404b97830b6ad05c03ede8fb25b5ad56b
Author: Romain GARBAGE <[email protected]>
AuthorDate: Mon Feb 24 15:38:09 2025 +0100
register: Add support for event logging in builders.
* src/cuirass/base.scm (local-builder, spawn-local-builder, remote-builder,
spawn-remote-builder): Add support for logging events to the corresponding
agent through Fibers.
* src/cuirass/scripts/register.scm (cuirass-register): Add event-log-service
agent and use it in builders.
* tests/remote.scm (start-notification-server): Add event-log-service agent.
Signed-off-by: Ludovic Courtès <[email protected]>
---
src/cuirass/base.scm | 29 ++++++++++++++++++++---------
src/cuirass/scripts/register.scm | 5 +++--
tests/remote.scm | 5 +++--
3 files changed, 26 insertions(+), 13 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index fa3481f..efa3dc8 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -439,7 +439,7 @@ OUTPUTS, a list of <build-output> records."
(checksum "")))))) ;TODO: Implement it.
outputs))
-(define (local-builder channel)
+(define (local-builder channel event-log)
(lambda ()
(log-info "builds will be made via the local build daemon")
(let loop ()
@@ -460,14 +460,22 @@ OUTPUTS, a list of <build-output> records."
(fail (- (length derivations) success)))
(log-info "outputs:\n~a" (string-join outs "\n"))
+ ;; Log the same kind of information as remote-builder.
+ (for-each (lambda (build)
+ (put-message event-log
+ `(new-event (derivation-built
+ ,(build-derivation build)
+ ,(build-current-status build)))))
+ results)
results))))))
(loop))))
-(define (spawn-local-builder)
+(define (spawn-local-builder event-log)
"Spawn a build actor that executes the derivation build requests it receives
-by handing them to the local build daemon."
+by handing them to the local build daemon. The build actor sends the build
+status to the event log service through EVENT-LOG, a Fibers channel."
(let ((channel (make-channel)))
- (spawn-fiber (local-builder channel))
+ (spawn-fiber (local-builder channel event-log))
channel))
(define (remote-builder-listener socket channel)
@@ -492,9 +500,10 @@ reads to CHANNEL."
(serve-client connection)))
(loop))))))
-(define (remote-builder channel socket)
+(define (remote-builder channel socket event-log)
"Spawn a remote builder that accepts messages on CHANNEL and receives
-notifications from 'cuirass remote-server' over SOCKET."
+notifications from 'cuirass remote-server' over SOCKET. It also sends the log
+events to the event log service using EVENT-LOG, a Fibers channel."
(lambda ()
(log-info "builds will be delegated to 'cuirass remote-server'")
(spawn-fiber (remote-builder-listener socket channel))
@@ -508,10 +517,12 @@ notifications from 'cuirass remote-server' over SOCKET."
(log-info "~a pending derivation builds" (length derivations)))
(`(build-status-change ,derivation ,status)
;; TODO: Handle database operations, notifications, etc. from here.
- (log-info "status of '~a' changed to ~a" derivation status)))
+ (log-info "status of '~a' changed to ~a" derivation status)
+ (put-message event-log
+ `(new-event (derivation-built ,derivation ,status)))))
(loop))))
-(define (spawn-remote-builder)
+(define (spawn-remote-builder event-log)
"Spawn a build actor that performs builds using \"remote workers\". Return
once ready to listen for incoming connections from 'cuirass remote-server'."
(log-info "listening for 'cuirass remote-server' notifications on '~a'"
@@ -519,7 +530,7 @@ once ready to listen for incoming connections from 'cuirass
remote-server'."
(let ((channel (make-channel))
(socket (open-unix-listening-socket
(%remote-server-socket-file-name))))
- (spawn-fiber (remote-builder channel socket))
+ (spawn-fiber (remote-builder channel socket event-log))
channel))
diff --git a/src/cuirass/scripts/register.scm b/src/cuirass/scripts/register.scm
index e32fe52..1698a8c 100644
--- a/src/cuirass/scripts/register.scm
+++ b/src/cuirass/scripts/register.scm
@@ -271,9 +271,10 @@
(if one-shot?
(leave (G_ "'--one-shot' is currently unimplemented~%"))
(let* ((exit-channel (make-channel))
+ (event-log-service (spawn-event-log-service))
(builder (if (option-ref opts 'build-remote #f)
- (spawn-remote-builder)
- (spawn-local-builder)))
+ (spawn-remote-builder event-log-service)
+ (spawn-local-builder
event-log-service)))
(evaluator (spawn-jobset-evaluator
#:max-parallel-evaluations
max-parallel-evaluations
diff --git a/tests/remote.scm b/tests/remote.scm
index 4a2e686..bfc1add 100644
--- a/tests/remote.scm
+++ b/tests/remote.scm
@@ -30,7 +30,8 @@
(cuirass specification)
((cuirass remote) #:select (worker-systems))
((cuirass base) #:select (%remote-server-socket-file-name
- spawn-remote-builder))
+ spawn-remote-builder
+ spawn-event-log-service))
(gnu packages base)
(guix build utils)
(guix channels)
@@ -111,7 +112,7 @@
(setvbuf (current-error-port) 'none)
(run-fibers
(lambda ()
- (spawn-remote-builder)
+ (spawn-remote-builder
(spawn-event-log-service))
(sleep 120)) ;wait
#:drain? #t)))))))
;; Wait until this process is accepting connections.
