diff options
| -rw-r--r-- | guix-build-coordinator/agent-messaging/http.scm | 8 | ||||
| -rw-r--r-- | guix-build-coordinator/utils.scm | 14 |
2 files changed, 21 insertions, 1 deletions
diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm index b02c598..cec0168 100644 --- a/guix-build-coordinator/agent-messaging/http.scm +++ b/guix-build-coordinator/agent-messaging/http.scm @@ -318,6 +318,12 @@ (if resume? "/partial" "")))) (define (perform-upload) + (define reset-timeout/throttled + (throttle + 120 + (lambda () + (reset-timeout (* 5 60))))) + (let* ((partial-upload-bytes (get-partial-upload-bytes)) (completed-upload-bytes (get-completed-upload-bytes)) (bytes (or partial-upload-bytes @@ -355,7 +361,7 @@ #:method (if bytes 'POST 'PUT) #:report-bytes-sent (lambda args - (reset-timeout (* 5 60)) + (reset-timeout/throttled) (apply report-bytes-sent args))))) (log 'DEBUG "perform upload " file ", response code: " (response-code response)) diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm index 3d2e1e8..eee2640 100644 --- a/guix-build-coordinator/utils.scm +++ b/guix-build-coordinator/utils.scm @@ -80,6 +80,8 @@ with-timeout reset-timeout + throttle + get-load-average running-on-the-hurd? @@ -1115,6 +1117,18 @@ again." (define (reset-timeout duration) (alarm duration)) +(define (throttle min-duration thunk) + (let ((next-min-runtime 0)) + (lambda () + (if (> (get-internal-real-time) + next-min-runtime) + (begin + (set! next-min-runtime + (+ (get-internal-real-time) + (* min-duration internal-time-units-per-second))) + (thunk)) + #f)))) + (define* (get-load-average #:key (period 5)) (if (file-exists? "/proc/loadavg") (let ((line (call-with-input-file "/proc/loadavg" get-line))) |