89 lines
3.4 KiB
Racket
89 lines
3.4 KiB
Racket
#lang scheme
|
|
(require scheme/sandbox)
|
|
|
|
(define timeout/c (and/c integer? positive?))
|
|
(define memory-limit/c (and/c integer? positive?))
|
|
(define sandbox-result/c (or/c exn? (listof any/c)))
|
|
(define eval-expression/c any/c)
|
|
|
|
(define memory-accounting?
|
|
(custodian-memory-accounting-available?))
|
|
|
|
(provide exn:fail:cpu-resource? exn:fail:cpu-resource-resource)
|
|
(define-struct (exn:fail:cpu-resource exn:fail) (resource))
|
|
|
|
|
|
(provide/contract
|
|
(call-with-limits/cpu-time
|
|
(timeout/c (-> any) . -> . any)))
|
|
(define (call-with-limits/cpu-time sec thunk)
|
|
(let ([ch (make-channel)]
|
|
;; use this to copy parameter changes from the sub-thread
|
|
[p current-preserved-thread-cell-values])
|
|
(let* ([start-cpu-time (current-process-milliseconds)]
|
|
; cpu-time is modulo fixnum, so we may never reach end-cpu-time
|
|
[end-cpu-time (+ start-cpu-time (* 1000 sec))]
|
|
[work
|
|
(thread (lambda ()
|
|
(channel-put ch
|
|
(with-handlers ([void (lambda (e)
|
|
(list (p) raise e))])
|
|
(call-with-values thunk
|
|
(lambda vs (list* (p) values vs)))))))]
|
|
[watch (thread
|
|
(λ ()
|
|
(channel-put
|
|
ch (let loop ([wait-sec
|
|
(quotient
|
|
(- end-cpu-time (current-process-milliseconds))
|
|
1000)])
|
|
; Wait for sec. The process would have got < sec cpu-time.
|
|
(sync/timeout wait-sec work)
|
|
(if (>= (current-process-milliseconds) end-cpu-time)
|
|
'time
|
|
(loop (quotient
|
|
(- end-cpu-time (current-process-milliseconds))
|
|
1000)))))))]
|
|
[r (channel-get ch)])
|
|
(kill-thread watch)
|
|
(if (list? r)
|
|
;; apply parameter changes first
|
|
(begin (p (car r)) (apply (cadr r) (cddr r)))
|
|
(raise (make-exn:fail:cpu-resource "out of cpu time"
|
|
(current-continuation-marks)
|
|
r))))))
|
|
|
|
|
|
(provide evaluate/limits/cpu-time)
|
|
(define (evaluate/limits/cpu-time evaluator memory-limit cpu-time-limit expr)
|
|
(parameterize ([sandbox-eval-limits `(#f ,memory-limit)])
|
|
(call-with-limits/cpu-time
|
|
cpu-time-limit
|
|
(λ () (evaluator expr)))))
|
|
|
|
|
|
|
|
#|(provide/contract
|
|
(sandbox-execution (timeout/c memory-limit/c eval-expression/c
|
|
. -> . sandbox-result/c)))|#
|
|
|
|
(provide sandbox-execution)
|
|
|
|
(define-struct (exn:sandbox:unknown exn:fail) (value))
|
|
|
|
(define (sandbox-execution timeout memory-limit language requires body to-evaluate)
|
|
(with-handlers ([exn? (λ (exn) exn)]
|
|
[(λ (x) #t)
|
|
(λ (v)
|
|
(make-exn:sandbox:unknown
|
|
v "not a subclass of exn:fail"
|
|
(current-continuation-marks)))])
|
|
|
|
(call-with-values
|
|
(λ ()
|
|
(parameterize ([sandbox-eval-limits `(,timeout ,memory-limit)])
|
|
(let ([evaluator (make-evaluator language requires body)])
|
|
(evaluator to-evaluate))))
|
|
(λ results results))))
|
|
|