diff options
| -rw-r--r-- | nar-herder/cached-compression.scm | 37 | ||||
| -rw-r--r-- | nar-herder/mirror.scm | 15 | ||||
| -rw-r--r-- | nar-herder/storage.scm | 80 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 61 |
4 files changed, 104 insertions, 89 deletions
diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm index dd542ec..ef10e40 100644 --- a/nar-herder/cached-compression.scm +++ b/nar-herder/cached-compression.scm @@ -470,23 +470,26 @@ (delete-file filename) (raise-exception exn)) (lambda () - (call-with-values - (lambda () - (let ((port - socket - (open-socket-for-uri* uri))) - (http-get uri - #:port port - #:decode-body? #f - #:streaming? #t))) - (lambda (response body) - (unless (= (response-code response) - 200) - (error "unknown response code" - (response-code response))) - - (dump-port body output-port))) - (close-port output-port)))) + (with-fibers-port-timeouts + (lambda () + (call-with-values + (lambda () + (let ((port + socket + (open-socket-for-uri* uri))) + (http-get uri + #:port port + #:decode-body? #f + #:streaming? #t))) + (lambda (response body) + (unless (= (response-code response) + 200) + (error "unknown response code" + (response-code response))) + + (dump-port body output-port))) + (close-port output-port)) + #:timeout 30)) #:unwind? #t) filename)) diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm index 19c1be9..6c39a02 100644 --- a/nar-herder/mirror.scm +++ b/nar-herder/mirror.scm @@ -78,12 +78,15 @@ (lambda () (log-msg 'INFO "querying for recent changes since " latest-recent-change) - (let ((port - socket - (open-socket-for-uri* uri))) - (http-get uri - #:port port - #:decode-body? #f))) + (with-fibers-port-timeouts + (lambda () + (let ((port + socket + (open-socket-for-uri* uri))) + (http-get uri + #:port port + #:decode-body? #f))) + #:timeout 30)) #:times 3 #:delay 15)) (lambda (response body) diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm index 99153b3..a88f0f1 100644 --- a/nar-herder/storage.scm +++ b/nar-herder/storage.scm @@ -409,26 +409,29 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (store-path-hash-part (assq-ref narinfo 'store-path)) ".narinfo/info")))) - (call-with-values - (lambda () - (retry-on-error + (with-fibers-port-timeouts + (lambda () + (call-with-values (lambda () - (call-with-cached-connection uri - (lambda (port) - (http-get uri - #:port port - #:decode-body? #f - #:keep-alive? #t - #:streaming? #t)))) - #:times 3 - #:delay 5)) - (lambda (response body) - (and (= (response-code response) - 200) - - (let ((json-body (json->scm body))) - (eq? (assoc-ref json-body "stored") - #t))))))))) + (retry-on-error + (lambda () + (call-with-cached-connection uri + (lambda (port) + (http-get uri + #:port port + #:decode-body? #f + #:keep-alive? #t + #:streaming? #t)))) + #:times 3 + #:delay 5)) + (lambda (response body) + (and (= (response-code response) + 200) + + (let ((json-body (json->scm body))) + (eq? (assoc-ref json-body "stored") + #t)))))) + #:timeout 30))))) (define (nar-can-be-removed? nar) (any (lambda (criteria) @@ -536,24 +539,27 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (raise-exception exn)) (lambda () - (call-with-values - (lambda () - (let ((port - socket - (open-socket-for-uri* uri))) - (http-get uri - #:port port - #:decode-body? #f - #:streaming? #t))) - (lambda (response body) - (unless (= (response-code response) - 200) - (error "unknown response code" - (response-code response))) - - (call-with-output-file tmp-file-name - (lambda (output-port) - (dump-port body output-port)))))) + (with-fibers-port-timeouts + (lambda () + (call-with-values + (lambda () + (let ((port + socket + (open-socket-for-uri* uri))) + (http-get uri + #:port port + #:decode-body? #f + #:streaming? #t))) + (lambda (response body) + (unless (= (response-code response) + 200) + (error "unknown response code" + (response-code response))) + + (call-with-output-file tmp-file-name + (lambda (output-port) + (dump-port body output-port)))))) + #:timeout 30)) #:unwind? #t) (rename-file tmp-file-name diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index ac3002b..e9d3150 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -474,35 +474,38 @@ (string->uri (string-append (assq-ref opts 'mirror) "/latest-database-dump")))) - (call-with-values - (lambda () - (simple-format (current-error-port) - "starting downloading the database\n") - (http-get database-uri - #:decode-body? #f - #:streaming? #t)) - (lambda (response body) - (when (not (= (response-code response) 200)) - (error "unable to fetch database from mirror")) - - (let* ((reporter (progress-reporter/file - (uri->string database-uri) - (response-content-length response) - (current-error-port))) - (port - (progress-report-port - reporter - body - #:download-size (response-content-length response)))) - - (call-with-output-file (assq-ref opts 'database) - (lambda (output-port) - (dump-port port output-port))) - - (close-port port)) - - (simple-format (current-error-port) - "finished downloading the database\n"))))) + (with-fibers-port-timeouts + (lambda () + (call-with-values + (lambda () + (simple-format (current-error-port) + "starting downloading the database\n") + (http-get database-uri + #:decode-body? #f + #:streaming? #t)) + (lambda (response body) + (when (not (= (response-code response) 200)) + (error "unable to fetch database from mirror")) + + (let* ((reporter (progress-reporter/file + (uri->string database-uri) + (response-content-length response) + (current-error-port))) + (port + (progress-report-port + reporter + body + #:download-size (response-content-length response)))) + + (call-with-output-file (assq-ref opts 'database) + (lambda (output-port) + (dump-port port output-port))) + + (close-port port)) + + (simple-format (current-error-port) + "finished downloading the database\n")))) + #:timeout 30))) (add-handler! lgr port-log) (open-log! lgr) |