aboutsummaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2020-05-16 13:23:04 +0100
committerChristopher Baines <mail@cbaines.net>2020-05-17 19:25:18 +0100
commit8053c67af3ad3d5a2467a6d12a06562df00c9969 (patch)
tree6a02a6d32be61381eb7be0c41ed7c9b5c155095b /scripts
parentc3d4942323206a5dedd93a9534a82e3589ef5dae (diff)
downloadbuild-coordinator-8053c67af3ad3d5a2467a6d12a06562df00c9969.tar
build-coordinator-8053c67af3ad3d5a2467a6d12a06562df00c9969.tar.gz
Open up more fibers possibilities in the coordinator
I'm looking to listen for client instructions ("build this", ...) maybe on a UNIX socket, which looks to be possible with fibers, but doing this at the same time as using a network socket for agent messaging requires more access than run-server from the fibers web server module currently allows. To get around this, patch the fibers web server run-server procedure to do less, and do that instead in the guix-build-coordinator. This is somewhat similar to what I think Cuirass does to allow it to do more with fibers. This required messing with the current-fiber parameter in a couple more places around threads, I'm not really sure why that problem has occurred now. This current-fiber parameter issue should be resolved in the next fibers release. One good thing with these changes is some behaviours not related to agent communication, like triggering build allocation on startup have been moved out of the agent communication code.
Diffstat (limited to 'scripts')
-rw-r--r--scripts/guix-build-coordinator.in102
1 files changed, 89 insertions, 13 deletions
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 02ae22d..c7267e9 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -26,6 +26,8 @@
(srfi srfi-37)
(ice-9 match)
(web uri)
+ (fibers)
+ (fibers conditions)
((guix ui) #:select (read/eval))
(guix derivations)
(guix-build-coordinator hooks)
@@ -180,6 +182,41 @@
(alist-delete 'arguments result)))
defaults))
+;; Patch the fibers web server to allow running multiple servers
+
+(let ((fibers-web-server-module
+ (resolve-module '(fibers web server))))
+
+ (define set-nonblocking!
+ (module-ref fibers-web-server-module 'set-nonblocking!))
+
+ (define make-default-socket
+ (module-ref fibers-web-server-module 'make-default-socket))
+
+ (define socket-loop
+ (module-ref fibers-web-server-module 'socket-loop))
+
+ (define* (run-server/patched handler #:key
+ (host #f)
+ (family AF_INET)
+ (addr (if host
+ (inet-pton family host)
+ INADDR_LOOPBACK))
+ (port 8080)
+ (socket (make-default-socket family addr port)))
+ ;; We use a large backlog by default. If the server is suddenly hit
+ ;; with a number of connections on a small backlog, clients won't
+ ;; receive confirmation for their SYN, leading them to retry --
+ ;; probably successfully, but with a large latency.
+ (listen socket 1024)
+ (set-nonblocking! socket)
+ (sigaction SIGPIPE SIG_IGN)
+ (spawn-fiber (lambda () (socket-loop socket handler))))
+
+ (module-set! (resolve-module '(fibers web server))
+ 'run-server
+ run-server/patched))
+
(setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line)
@@ -374,16 +411,55 @@ processed?: ~A
(parameterize ((%show-error-details
(assoc-ref opts 'show-error-details)))
- (let ((agent-communication-uri
- (string->uri (assq-ref opts 'agent-communication))))
- (match (uri-scheme agent-communication-uri)
- ('http
- (let ((host (uri-host agent-communication-uri))
- (port (uri-port agent-communication-uri)))
- (simple-format #t "listening on ~A:~A\n"
- host port)
- (http-agent-messaging-start-server
- port
- host
- (assq-ref opts 'secret-key-base)
- build-coordinator)))))))))
+ ;; Copied from (fibers web server)
+ (define (call-with-sigint thunk cvar)
+ (let ((handler #f))
+ (dynamic-wind
+ (lambda ()
+ (set! handler
+ (sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
+ thunk
+ (lambda ()
+ (if handler
+ ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+ (sigaction SIGINT (car handler) (cdr handler))
+ ;; restore original C handler.
+ (sigaction SIGINT #f))))))
+
+ (let* ((trigger-build-allocation
+ (make-build-allocator-thread build-coordinator))
+ (agent-communication-thunk
+ (let ((agent-communication-uri
+ (string->uri (assq-ref opts 'agent-communication))))
+ (match (uri-scheme agent-communication-uri)
+ ('http
+ (let ((host (uri-host agent-communication-uri))
+ (port (uri-port agent-communication-uri))
+ (chunked-request-channel
+ ;; There are fibers issues when trying to read the
+ ;; chunked requests
+ (make-worker-thread-channel (const '())
+ #:parallelism 8)))
+ (lambda ()
+ (simple-format #t "listening on ~A:~A\n"
+ host port)
+ (http-agent-messaging-start-server
+ port
+ host
+ (assq-ref opts 'secret-key-base)
+ build-coordinator
+ chunked-request-channel
+ trigger-build-allocation))))))))
+
+ (start-hook-processing-thread build-coordinator)
+ (trigger-build-allocation build-coordinator)
+
+ (let ((finished? (make-condition)))
+ (call-with-sigint
+ (lambda ()
+ (run-fibers
+ (lambda ()
+ (agent-communication-thunk)
+
+ (wait finished?))))
+ finished?)))))))