Don't use threads for substituting derivations

Instead use non-blocking store connections like Cuirass does.

1 files changed, 28 insertions, 4 deletions

diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 23c4fe2..17cabc8 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -405,6 +405,30 @@
                      substitute-urls)))
     substitute-urls))
 
+(define (non-blocking-port port)
+  "Make PORT non-blocking and return it."
+  (let ((flags (fcntl port F_GETFL)))
+    (when (zero? (logand O_NONBLOCK flags))
+      (fcntl port F_SETFL (logior O_NONBLOCK flags)))
+    port))
+
+(define (ensure-non-blocking-store-connection store)
+  "Mark the file descriptor that backs STORE, a <store-connection>, as
+O_NONBLOCK."
+  (match (store-connection-socket store)
+    ((? file-port? port)
+     (non-blocking-port port))
+    (_ #f)))
+
+(define-syntax-rule (with-store/non-blocking store exp ...)
+  "Like 'with-store', bind STORE to a connection to the store, but ensure that
+said connection is non-blocking (O_NONBLOCK).  Evaluate EXP... in that
+context."
+  (with-store store
+    (ensure-non-blocking-store-connection store)
+    (let ()
+      exp ...)))
+
 (define* (substitute-derivation derivation-name
                                 #:key substitute-urls)
   (let ((log-port (open-output-string)))
@@ -412,7 +436,7 @@
       (lambda ()
         (if (defined? 'ensure-path
               (resolve-module '(guix store)))
-            (with-store store
+            (with-store/non-blocking store
               (apply set-build-options
                      store
                      `(,@(if substitute-urls
@@ -427,7 +451,7 @@
                    (set-store-connection-timeout store)
                    (ensure-path store derivation-name))
                  #:timeout (* 120 1000))))
-            (with-store store
+            (with-store/non-blocking store
               (apply set-build-options
                      store
                      `(#:print-extended-build-trace? #t
@@ -452,7 +476,7 @@
           (close-output-port log-port)
           ;; This is a hack, to ignore errors relating to closing the store
           ;; connection.
-          (if (with-store store
+          (if (with-store/non-blocking store
                 (valid-path? store derivation-name))
               #t
               (begin
@@ -570,7 +594,7 @@
                           #f))
           (error "could not fetch narinfo"))))
 
-  (with-store store
+  (with-store/non-blocking store
     (define (read-derivation-from-file/custom derivation-name)
       (or (hash-ref %derivation-cache derivation-name)