Have agents report on the progress of the coordinator hashing outputs

Otherwise it looks like the upload should finish, but hasn't.

2 files changed, 87 insertions, 42 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 9a2732d..01a2c15 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -281,7 +281,8 @@
    (lambda* (build-id output-name file
                       #:key
                       (log default-log)
-                      reporter)
+                      reporter
+                      report-bytes-hashed)
      (define file-size
        (stat:size (stat file)))
 
@@ -377,7 +378,14 @@
                                         #:reporter reporter)))
                         #:binary #t)))
                   #:headers `((Authorization . ,auth-value))
-                  #:method (if bytes 'POST 'PUT))))
+                  #:method (if bytes 'POST 'PUT)
+                  #:streaming? #t)))
+
+           (let loop ((line (get-line body)))
+             (unless (eof-object? line)
+               (report-bytes-hashed
+                (string->number line))
+               (loop (get-line body))))
 
            (log 'DEBUG "perform upload " file ", response code: "
                 (response-code response))
diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index ce25588..2779063 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -52,10 +52,14 @@
   #:export (run-agent))
 
 (define-record-type <upload-progress>
-  (make-upload-progress file bytes-sent total-bytes)
+  (make-upload-progress file bytes-sent bytes-hashed
+                        total-bytes)
   upload-progress?
   (file          upload-progress-file)
-  (bytes-sent    upload-progress-bytes-sent  set-upload-progress-bytes-sent!)
+  (bytes-sent    upload-progress-bytes-sent
+                 set-upload-progress-bytes-sent!)
+  (bytes-hashed  upload-progress-bytes-hashed
+                 set-upload-progress-bytes-hashed!)
   (total-bytes   upload-progress-total-bytes))
 
 (define temporary-directory
@@ -125,11 +129,47 @@
 
   (define (with-upload-monitoring lgr file total-bytes p)
     (define upload-progress-record
-      (make-upload-progress file 0 total-bytes))
+      (make-upload-progress file 0 0 total-bytes))
 
     (define last-progress-update-bytes-sent 0)
+    (define last-progress-update-bytes-hashed 0)
     (define last-progress-update-time 0)
 
+    (define (display-update)
+      (let ((uploads-count
+             (vector-count (lambda (_ slot)
+                             (not (eq? #f slot)))
+                           upload-slots)))
+        (log-msg lgr 'INFO uploads-count " uploads in progress")
+
+        (vector-for-each
+         (lambda (_ upload-progress)
+           (when upload-progress
+             (log-msg lgr 'INFO
+                      (upload-progress-file upload-progress)
+                      ": "
+                      (let ((total-bytes
+                             (upload-progress-total-bytes upload-progress))
+                            (bytes-sent
+                             (upload-progress-bytes-sent
+                              upload-progress))
+                            (bytes-hashed
+                             (upload-progress-bytes-hashed
+                              upload-progress)))
+                        (if (and (= bytes-sent total-bytes)
+                                 (> bytes-hashed 0))
+                            (format
+                             #f
+                             "uploaded, ~2,2f/~2,2fMB hashed"
+                             (/ bytes-hashed 1000000)
+                             (/ total-bytes 1000000))
+                            (format
+                             #f
+                             "~2,2f/~2,2fMB sent"
+                             (/ bytes-sent 1000000)
+                             (/ total-bytes 1000000)))))))
+         upload-slots)))
+
     (define (report-bytes-sent bytes-now-sent)
       (if (eq? bytes-now-sent 'reset)
           (begin
@@ -140,44 +180,39 @@
             (set-upload-progress-bytes-sent!
              upload-progress-record
              bytes-now-sent)
-            (let ((uploads-count
-                   (vector-count (lambda (_ slot)
-                                   (not (eq? #f slot)))
-                                 upload-slots)))
-
-              (when (or (> bytes-now-sent
-                           (+ last-progress-update-bytes-sent 10000000))
-                        (and (> (- (time-second (current-time)))
-                                (+ last-progress-update-time 15))))
-                (set! last-progress-update-bytes-sent
-                      bytes-now-sent)
-                (set! last-progress-update-time
-                      (time-second (current-time)))
-
-                (log-msg lgr 'INFO uploads-count " uploads in progress")
-
-                (vector-for-each
-                 (lambda (_ upload-progress)
-                   (when upload-progress
-                     (log-msg lgr 'INFO
-                              (upload-progress-file upload-progress)
-                              ": "
-                              (format
-                               #f
-                               "~2,2f/~2,2f"
-                               (/ (upload-progress-bytes-sent
-                                   upload-progress)
-                                  1000000)
-                               (/ (upload-progress-total-bytes upload-progress)
-                                  1000000))
-                              "MB sent")))
-                 upload-slots))))))
+
+            (when (or (> bytes-now-sent
+                         (+ last-progress-update-bytes-sent 10000000))
+                      (and (> (- (time-second (current-time)))
+                              (+ last-progress-update-time 15))))
+              (set! last-progress-update-bytes-sent
+                    bytes-now-sent)
+              (set! last-progress-update-time
+                    (time-second (current-time)))
+
+              (display-update)))))
 
     (define reporter
       (make-progress-reporter
-       (const #t)
+       (lambda ()
+         (report-bytes-sent 'reset))
        report-bytes-sent
-       (const #t)))
+       (lambda ()
+         (report-bytes-sent total-bytes))))
+
+    (define (report-bytes-hashed bytes-now-hashed)
+      (set-upload-progress-bytes-hashed! upload-progress-record
+                                         bytes-now-hashed)
+      (when (or (> bytes-now-hashed
+                   (+ last-progress-update-bytes-hashed 10000000))
+                (and (> (- (time-second (current-time)))
+                        (+ last-progress-update-time 15))))
+        (set! last-progress-update-bytes-hashed
+              bytes-now-hashed)
+        (set! last-progress-update-time
+              (time-second (current-time)))
+
+        (display-update)))
 
     (define (free-slot index)
       (with-mutex uploads-mutex
@@ -215,7 +250,8 @@
 
                           (raise-exception exn))
                       (lambda ()
-                        (p reporter))
+                        (p reporter
+                           report-bytes-hashed))
                       #:unwind? #t))
                 (lambda vals
                   (free-slot free-index)
@@ -1084,7 +1120,7 @@ but the guix-daemon claims it's unavailable"
      lgr
      (derivation-output-path output)
      bytes
-     (lambda (reporter)
+     (lambda (reporter report-bytes-hashed)
        (log-msg lgr 'INFO
                 build-id ": submitting output "
                 (derivation-output-path output))
@@ -1092,7 +1128,8 @@ but the guix-daemon claims it's unavailable"
                       build-id output-name
                       compressed-file
                       #:log (build-log-procedure lgr build-id)
-                      #:reporter reporter)
+                      #:reporter reporter
+                      #:report-bytes-hashed report-bytes-hashed)
        (log-msg lgr 'INFO
                 build-id ": finished submitting output "
                 (derivation-output-path output)))))