Fix the make-chunked-output-port* implementation

A broken one was committed previously.

1 files changed, 24 insertions, 12 deletions

diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 9887d05..0150257 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -262,32 +262,44 @@ upcoming chunk."
 
 (define* (make-chunked-output-port* port #:key (keep-alive? #f)
                                     (buffering 1200))
+  (define initial-heap-size
+    (assq-ref (gc-stats) 'heap-size))
+
   (define (%put-string s)
-    (let ((length (string-length s)))
-      (unless (eq? length 0)
+    (unless (string-null? s)
+      (let* ((bv (string->bytevector s "ISO-8859-1"))
+             (length (bytevector-length bv)))
         (with-gc-protection
          (lambda ()
            (put-string port (number->string length 16))
            (put-string port "\r\n")
-           (write s port)
-           (put-string port "\r\n"))))))
+           (put-bytevector port bv)
+           (put-string port "\r\n")))
+
+        (let* ((stats (gc-stats))
+               (initial-gc-times
+                (assq-ref stats 'gc-times)))
+          (while (let ((updated-stats (gc-stats)))
+                   (and (> (assq-ref updated-stats 'heap-allocated-since-gc)
+                           initial-heap-size)
+                        (= initial-gc-times
+                           (assq-ref updated-stats 'gc-times))))
+            (gc)
+            (usleep 10))))))
+
   (define (%put-char c)
     (%put-string (list->string (list c))))
 
-  (define (flush)
-    (force-output port))
-  (define (safe-flush)
-    (with-gc-protection flush))
+  (define (flush) #t)
   (define (close)
     (with-gc-protection
      (lambda ()
-       (flush)
-       (put-string port "0\r\n\r\n")
-       (force-output port)
+       (put-string port "0\r\n")
        (unless keep-alive?
+         (force-output port)
          (close-port port)))))
   (let ((ret (make-soft-port
-              (vector %put-char %put-string safe-flush #f close) "w")))
+              (vector %put-char %put-string flush #f close) "w")))
     (setvbuf ret 'block buffering)
     ret))