Stop using with-port-timeouts

As this is incompatible with fibers.

4 files changed, 54 insertions, 131 deletions

diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm
index 92e0644..73eb789 100644
--- a/nar-herder/cached-compression.scm
+++ b/nar-herder/cached-compression.scm
@@ -470,27 +470,25 @@
                     (delete-file filename)
                     (raise-exception exn))
                 (lambda ()
-                  (with-port-timeouts
-                   (lambda ()
-                     (call-with-values
-                         (lambda ()
-                           (let ((port
-                                  socket
-                                  (open-socket-for-uri* uri)))
-                             (set-socket-timeout socket #:seconds 30)
-
-                             (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))))
+                  (call-with-values
+                      (lambda ()
+                        (let ((port
+                               socket
+                               (open-socket-for-uri* uri)))
+                          (set-socket-timeout socket #:seconds 30)
+
+                          (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))))
                 #:unwind? #t)
 
               filename))
diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm
index a87b898..56e1299 100644
--- a/nar-herder/mirror.scm
+++ b/nar-herder/mirror.scm
@@ -78,16 +78,14 @@
            (lambda ()
              (log-msg 'INFO "querying for recent changes since "
                       latest-recent-change)
-             (with-port-timeouts
-              (lambda ()
-                (let ((port
-                       socket
-                       (open-socket-for-uri* uri)))
-                  (set-socket-timeout socket #:seconds 20)
-
-                  (http-get uri
-                            #:port port
-                            #:decode-body? #f)))))
+             (let ((port
+                    socket
+                    (open-socket-for-uri* uri)))
+               (set-socket-timeout socket #:seconds 20)
+
+               (http-get uri
+                         #:port port
+                         #:decode-body? #f)))
            #:times 3
            #:delay 15))
       (lambda (response body)
diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm
index 8c1fd78..212c55e 100644
--- a/nar-herder/storage.scm
+++ b/nar-herder/storage.scm
@@ -413,15 +413,13 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
              (lambda ()
                (retry-on-error
                 (lambda ()
-                  (with-port-timeouts
-                   (lambda ()
-                     (call-with-cached-connection uri
-                       (lambda (port)
-                         (http-get uri
-                                   #:port port
-                                   #:decode-body? #f
-                                   #:keep-alive? #t
-                                   #:streaming? #t))))))
+                  (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)
@@ -538,28 +536,26 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
 
             (raise-exception exn))
         (lambda ()
-          (with-port-timeouts
-           (lambda ()
-             (call-with-values
-                 (lambda ()
-                   (let ((port
-                          socket
-                          (open-socket-for-uri* uri)))
-                     (set-socket-timeout socket #:seconds 30)
-
-                     (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))))))))
+          (call-with-values
+              (lambda ()
+                (let ((port
+                       socket
+                       (open-socket-for-uri* uri)))
+                  (set-socket-timeout socket #:seconds 30)
+
+                  (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))))))
         #:unwind? #t)
 
       (rename-file tmp-file-name
diff --git a/nar-herder/utils.scm b/nar-herder/utils.scm
index f57c27b..552ef02 100644
--- a/nar-herder/utils.scm
+++ b/nar-herder/utils.scm
@@ -54,7 +54,6 @@
 
             check-locale!
 
-            with-port-timeouts
             set-socket-timeout
             open-socket-for-uri*
 
@@ -545,74 +544,6 @@ If already in the worker thread, call PROC immediately."
                (duration-logger duration))
              (apply values result)))))))
 
-(define &port-timeout
-  (make-exception-type '&port-timeout
-                       &external-error
-                       '(port)))
-
-(define make-port-timeout-error
-  (record-constructor &port-timeout))
-
-(define port-timeout-error?
-  (record-predicate &port-timeout))
-
-(define &port-read-timeout
-  (make-exception-type '&port-read-timeout
-                       &port-timeout
-                       '()))
-
-(define make-port-read-timeout-error
-  (record-constructor &port-read-timeout))
-
-(define port-read-timeout-error?
-  (record-predicate &port-read-timeout))
-
-(define &port-write-timeout
-  (make-exception-type '&port-write-timeout
-                       &port-timeout
-                       '()))
-
-(define make-port-write-timeout-error
-  (record-constructor &port-write-timeout))
-
-(define port-write-timeout-error?
-  (record-predicate &port-write-timeout))
-
-(define* (with-port-timeouts thunk #:key (timeout (* 120 1000)))
-
-  ;; When the GC runs, it restarts the poll syscall, but the timeout remains
-  ;; unchanged! When the timeout is longer than the time between the syscall
-  ;; restarting, I think this renders the timeout useless. Therefore, this
-  ;; code uses a short timeout, and repeatedly calls poll while watching the
-  ;; clock to see if it has timed out overall.
-  (define poll-timeout-ms 200)
-
-  (define (wait port mode)
-    (let ((timeout-internal
-           (+ (get-internal-real-time)
-              (* internal-time-units-per-second
-                 (/ timeout 1000)))))
-      (let loop ((poll-value
-                  (port-poll port mode poll-timeout-ms)))
-        (if (= poll-value 0)
-            (if (> (get-internal-real-time)
-                   timeout-internal)
-                (raise-exception
-                 (if (string=? mode "r")
-                     (make-port-read-timeout-error port)
-                     (make-port-write-timeout-error port)))
-                (loop (port-poll port mode poll-timeout-ms)))
-            poll-value))))
-
-  (parameterize
-      ((current-read-waiter
-        (lambda (port)
-          (wait port "r")))
-       (current-write-waiter
-        (lambda (port)
-          (wait port "w"))))
-    (thunk)))
-
 (define* (set-socket-timeout port #:key (seconds 120))
   (when (defined? 'SO_RCVTIMEO)
     ;; This is only supported on Guile 3.0.9 and later