From c9d71251dc979dc220864a099c4c0fdad5cd0fa2 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 28 May 2021 14:25:20 +0100
Subject: Tune sending files over HTTP

Guile's garbage collector interferes with Guile+gnutls, which means that
sending files while the garbage collector is active is difficult.

These changes try to work around this by disabling the garbage collector just
as the data is being written, then enabling it again. I think this helps to
work around the issue.
---
 guix-build-coordinator/agent-messaging/http.scm |  4 +--
 guix-build-coordinator/utils.scm                | 40 +++++++++++++++++++++----
 2 files changed, 37 insertions(+), 7 deletions(-)

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 70b4bb7..da5c682 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -311,7 +311,7 @@
                                       (with-time-logging
                                           (simple-format #f "sending ~A" file)
                                         (dump-port file-port port
-                                                   #:buffer-size (expt 2 20))))
+                                                   #:buffer-size 32768)))
                                     #:headers `((Authorization . ,auth-value)))))
                        (when (>= (response-code response) 400)
                          (raise-exception
@@ -365,7 +365,7 @@
                             (call-with-input-file file
                               (lambda (file-port)
                                 (dump-port file-port request-port
-                                           #:buffer-size (expt 2 20)))
+                                           #:buffer-size 32768))
                               #:binary #t))
                           #:headers `((Authorization . ,auth-value)))))
              (if (>= (response-code response) 400)
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 31a4909..0f51a20 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -251,6 +251,33 @@ upcoming chunk."
              (parse-query-string query))
         '())))
 
+(define (with-gc-protection thunk)
+  (monitor
+   (gc-disable)
+   (thunk)
+   (gc-enable)))
+
+(define (make-gc-guard-port port)
+  (define (%put-char c)
+    (write c port))
+
+  (define (%put-string s)
+    (display s port))
+
+  (define (flush)
+    (with-gc-protection
+     (lambda ()
+       (force-output port))))
+
+  (define (close)
+    (with-gc-protection
+     (lambda ()
+       (close-port port))))
+
+  (make-soft-port
+   (vector %put-char %put-string flush #f close)
+   "w"))
+
 (define* (call-with-streaming-http-request uri callback
                                            #:key (headers '()))
   (let* ((port (open-socket-for-uri uri))
@@ -266,7 +293,7 @@ upcoming chunk."
            #:port port)))
 
     (set-port-encoding! port "ISO-8859-1")
-    (setvbuf port 'block (expt 2 20))
+    (setvbuf port 'block 32768)
     (with-exception-handler
         (lambda (exp)
           (simple-format #t "error: PUT ~A: ~A\n" (uri-path uri) exp)
@@ -275,10 +302,13 @@ upcoming chunk."
       (lambda ()
         (let ((request (write-request request port)))
           (let ((chunked-output-port
-                 (make-chunked-output-port
-                  port
-                  #:buffering (expt 2 20)
-                  #:keep-alive? #t)))
+                 (make-gc-guard-port
+                  (make-chunked-output-port
+                   port
+                   #:buffering 32768
+                   #:keep-alive? #t))))
+
+            (setvbuf chunked-output-port 'block 32768)
 
             ;; A SIGPIPE will kill Guile, so ignore it
             (sigaction SIGPIPE
-- 
cgit v1.2.3