diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/guix-build-coordinator.in | 102 |
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?))))))) |