Split the fibers utils from the main utils module

To start making it possible to use the agent, without having to load anything
related to fibers (as it doesn't work on the hurd yet).

1 files changed, 115 insertions, 0 deletions

diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm
new file mode 100644
index 0000000..a39b3bb
--- /dev/null
+++ b/guix-build-coordinator/utils/fibers.scm
@@ -0,0 +1,115 @@
+(define-module (guix-build-coordinator utils fibers)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
+  #:use-module (fibers)
+  #:use-module (fibers channels)
+  #:use-module (fibers conditions)
+  #:export (make-worker-thread-channel
+            call-with-worker-thread
+
+            call-with-sigint
+
+            run-server/patched))
+
+(define %worker-thread-args
+  (make-parameter #f))
+
+(define* (make-worker-thread-channel initializer
+                                     #:key (parallelism 1))
+  "Return a channel used to offload work to a dedicated thread.  ARGS are the
+arguments of the worker thread procedure."
+  (parameterize (((@@ (fibers internal) current-fiber) #f))
+    (let ((channel (make-channel)))
+      (for-each
+       (lambda _
+         (let ((args (initializer)))
+           (call-with-new-thread
+            (lambda ()
+              (parameterize ((%worker-thread-args args))
+                (let loop ()
+                  (match (get-message channel)
+                    (((? channel? reply) . (? procedure? proc))
+                     (put-message
+                      reply
+                      (with-exception-handler
+                          (lambda (exn)
+                            (cons 'worker-thread-error exn))
+                        (lambda ()
+                          (with-exception-handler
+                              (lambda (exn)
+                                (simple-format
+                                 (current-error-port)
+                                 "worker-thread: exception: ~A\n" exn)
+                                (backtrace)
+                                (raise-exception exn))
+                            (lambda ()
+                              (call-with-values
+                                  (lambda ()
+                                    (apply proc args))
+                                (lambda vals vals)))))
+                        #:unwind? #t))))
+                  (loop)))))))
+       (iota parallelism))
+      channel)))
+
+(define (call-with-worker-thread channel proc)
+  "Send PROC to the worker thread through CHANNEL.  Return the result of PROC.
+If already in the worker thread, call PROC immediately."
+  (let ((args (%worker-thread-args)))
+    (if args
+        (apply proc args)
+        (let ((reply (make-channel)))
+          (put-message channel (cons reply proc))
+          (match (get-message reply)
+            (('worker-thread-error . exn)
+             (raise-exception exn))
+            (result
+             (apply values result)))))))
+
+;; 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))))))
+
+;; This variant of run-server from the fibers library supports running
+;; multiple servers within one process.
+(define run-server/patched
+  (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))
+
+    (lambda* (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))))))