From 500b14d65fe1a458aa34286572e1ddbf53249ddf Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 9 Sep 2023 12:33:22 +0100
Subject: Use fibers timeouts for all http requests

---
 scripts/nar-herder.in | 61 +++++++++++++++++++++++++++------------------------
 1 file changed, 32 insertions(+), 29 deletions(-)

(limited to 'scripts')

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)
-- 
cgit v1.2.3