#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)))))