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.

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