laten zien hoe downloads en zo gaan

2026-10-29 10:39:35 +01:00
parent f7f4d440b8
commit 3fda5c2485
8 changed files with 293 additions and 69 deletions
@@ -0,0 +1,120 @@
+#lang racket/base
+
+(require racket/async-channel)
+
+(provide call-with-http-timeout)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Bound HTTP inactivity while allowing transfers of any duration.
+; pre    : Seconds is positive. Proc consumes its HTTP ports before returning
+;          and calls progress! whenever new response bytes arrive.
+; post   : The worker has exited and its HTTP resources have been closed.
+; result : Proc's values, or its exception, or an inactivity timeout error.
+; internals: Activity restarts sync/timeout. On cancellation, a break unwinds
+;            semaphore and dynamic-wind cleanup before the custodian closes
+;            remaining ports. No timed-out worker can continue changing state.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (call-with-http-timeout seconds proc)
+  (let* ((custodian (make-custodian))
+         (activity (make-async-channel 1))
+         (result (make-async-channel))
+         (finished? #f)
+         (worker
+          (parameterize ((current-custodian custodian))
+            (thread
+             (λ ()
+               (with-handlers ((exn:break? void))
+                 (parameterize-break #t
+                   (with-handlers
+                       ((exn? (λ (exception)
+                                (async-channel-put result (cons #f exception)))))
+                     (let ((values-list
+                            (call-with-values
+                             (λ () (proc (λ () (async-channel-put activity #t))))
+                             list)))
+                       (async-channel-put result (cons #t values-list)))))))))))
+    (dynamic-wind
+      void
+      (λ ()
+        (let loop ()
+          (let ((event (sync/timeout seconds
+                                    (handle-evt result (λ (value) (cons 'result value)))
+                                    (handle-evt activity (λ (_) 'progress)))))
+            (cond
+              ((not event)
+               (error 'http-transfer "No HTTP progress for ~a seconds" seconds))
+              ((eq? event 'progress) (loop))
+              (else
+               (set! finished? #t)
+               (if (cadr event)
+                   (apply values (cddr event))
+                   (raise (cddr event))))))))
+      (λ ()
+        (unless (or finished? (thread-dead? worker))
+          (break-thread worker))
+        (thread-wait worker)
+        (custodian-shutdown-all custodian)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tests for module http-transfer.rkt
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module+ test
+  (require rackunit racket/file)
+
+  (check-equal? (call-with-values
+                (λ () (call-with-http-timeout 1 (λ (_) (values 1 2)))) list)
+                '(1 2))
+  (check-exn #rx"original failure"
+             (λ () (call-with-http-timeout 1 (λ (_) (error "original failure")))))
+
+  (test-case "continuing progress allows a transfer longer than its idle limit"
+    (check-equal?
+     (call-with-http-timeout
+      0.5
+      (λ (progress!)
+        (let loop ((chunks 6))
+          (unless (zero? chunks)
+            (sleep 0.15)
+            (progress!)
+            (loop (- chunks 1))))
+        'downloaded))
+     'downloaded))
+
+  (test-case "stalled HTTP workers release locks and close their ports"
+    (let ((lock (make-semaphore 1))
+          (output #f)
+          (target (make-temporary-file "http-stall-~a")))
+      (dynamic-wind
+        void
+        (λ ()
+          (check-exn
+           #rx"No HTTP progress"
+           (λ ()
+             (parameterize-break #f
+               (call-with-http-timeout
+                0.1
+                (λ (_)
+                  (set! output (open-output-file target #:exists 'truncate))
+                  (call-with-semaphore lock (λ () (sync never-evt))))))))
+          (check-true (semaphore-try-wait? lock))
+          (check-true (port-closed? output)))
+        (λ () (delete-file target)))))
+
+  (test-case "breaking the caller also unwinds its HTTP worker"
+    (let* ((ready (make-semaphore))
+           (lock (make-semaphore 1))
+           (caller
+            (thread
+             (λ ()
+               (with-handlers ((exn:break? void))
+                 (call-with-http-timeout
+                  5
+                  (λ (_)
+                    (call-with-semaphore
+                     lock
+                     (λ () (semaphore-post ready) (sync never-evt))))))))))
+      (semaphore-wait ready)
+      (break-thread caller)
+      (check-not-false (sync/timeout 2 caller))
+      (check-true (semaphore-try-wait? lock)))))