Permalink
Fetching contributors…
Cannot retrieve contributors at this time
45 lines (37 sloc) 1.67 KB
#lang racket/base
(provide (struct-out exn:fail:timeout)
call-with-timeout)
(define-struct (exn:fail:timeout exn:fail) (msecs))
(define-struct good-value (v))
(define-struct bad-value (exn))
;; call-with-timeout: (-> any) number -> any
;; Calls a thunk, with a given timeout.
(define (call-with-timeout thunk timeout)
(let ([ch (make-channel)]
[alarm-e
(alarm-evt (+ (current-inexact-milliseconds)
timeout))])
(let* ([cust (make-custodian)]
[th (parameterize ([current-custodian cust])
(thread (lambda ()
(channel-put ch
(with-handlers ([void
(lambda (e)
(make-bad-value e))])
(make-good-value (thunk)))))))])
(let ([result (sync ch
(handle-evt alarm-e
(lambda (false-value)
(begin0
(make-bad-value
(make-exn:fail:timeout
"timeout"
(current-continuation-marks)
timeout))
(custodian-shutdown-all cust)
(kill-thread th)))))])
(cond
[(good-value? result)
(good-value-v result)]
[(bad-value? result)
(raise (bad-value-exn result))])))))