Use fibers timeouts for all http requests

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)