suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sandbox break propagation

Browse Source 
svn: r14182
This commit is contained in:
Matthew Flatt 2009-03-19 12:31:33 +00:00
parent e52b23b881
commit 154b73755a
1 changed files with 67 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
collects/scheme/sandbox.ss
View File

@ -627,6 +627,7 @@
(define user-thread #t) ; set later to the thread
(define user-done-evt #t) ; set in the same place
(define terminated? #f) ; set to an exception value when the sandbox dies
(define breaks-originally-enabled? (break-enabled))
(define (limit-thunk thunk)
(let* ([sec (and limits (car limits))]
[mb (and limits (cadr limits))]
@ -665,42 +666,70 @@
(define (user-break)
(when user-thread (break-thread user-thread)))
(define (user-process)
(with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
;; first set up the environment
(init-hook)
((sandbox-init-hook))
;; now read and evaluate the input program
(evaluate-program
(if (procedure? program-maker) (program-maker) program-maker)
limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get))))
(channel-put result-ch 'ok))
(set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
;; finally wait for interaction expressions
(let ([n 0])
(let loop ()
(let ([expr (channel-get input-ch)])
(when (eof-object? expr)
(terminated! 'eof) (channel-put result-ch expr) (user-kill))
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
(define run
(if (evaluator-message? expr)
(case (evaluator-message-msg expr)
[(thunk) (limit-thunk (car (evaluator-message-args expr)))]
[(thunk*) (car (evaluator-message-args expr))]
[else (error 'sandbox "internal error (bad message)")])
(limit-thunk
(lambda ()
(set! n (add1 n))
(eval* (map (lambda (expr) (cons '#%top-interaction expr))
(input->code (list expr) 'eval n)))))))
(channel-put result-ch (cons 'vals (call-with-values run list))))
(loop)))))
(let ([break-paramz (current-break-parameterization)])
(parameterize-break
#f ;; disable breaks during administrative work
(with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
(call-with-break-parameterization
break-paramz
(lambda ()
;; enable breaks, maybe
(when breaks-originally-enabled? (break-enabled #t))
;; first set up the environment
(init-hook)
((sandbox-init-hook))
;; now read and evaluate the input program
(evaluate-program
(if (procedure? program-maker) (program-maker) program-maker)
limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get)))))))
(channel-put result-ch 'ok)
(set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
;; finally wait for interaction expressions
(let ([n 0])
(let loop ()
(let ([expr (channel-get input-ch)])
(when (eof-object? expr)
(terminated! 'eof) (channel-put result-ch expr) (user-kill))
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
(define run
(if (evaluator-message? expr)
(case (evaluator-message-msg expr)
[(thunk) (limit-thunk (car (evaluator-message-args expr)))]
[(thunk*) (car (evaluator-message-args expr))]
[else (error 'sandbox "internal error (bad message)")])
(limit-thunk
(lambda ()
(set! n (add1 n))
(eval* (map (lambda (expr) (cons '#%top-interaction expr))
(input->code (list expr) 'eval n)))))))
(channel-put result-ch (cons 'vals
(call-with-break-parameterization
break-paramz
(lambda ()
(call-with-values run list))))))
(loop)))))))
(define (get-user-result)
(with-handlers ([(if (sandbox-propagate-breaks) exn:break? (lambda (_) #f))
(lambda (e) (user-break) (get-user-result))])
(sync user-done-evt result-ch)))
(let ([get-result (lambda () (sync user-done-evt result-ch))])
(if (and (sandbox-propagate-breaks)
;; The following test is weird. We reliably catch breaks if breaks
;; are enabled, except that a break just before or after isn't
;; reliably propagated. A `get-result/enable-breaks' function
;; would make more sense.
(break-enabled))
;; The following loop ensures that breaks are disabled while trying
;; to handle a break, which ensures that we don't fail to
;; propagate a break.
(parameterize-break
#f
(let loop ()
(with-handlers* ([exn:break? (lambda (e) (user-break) (loop))])
(parameterize-break
#t
(get-result)))))
;; The same case doesn't have to deal with breaks:
(get-result))))
(define (user-eval expr)
;; the thread will usually be running, but it might be killed outside of
;; the sandboxed environment, for example, if you do something like
@ -856,7 +885,9 @@
;; evaluates the program in `run-in-bg') -- so this parameterization
;; must be nested in the above (which is what paramaterize* does), or
;; it will not use the new namespace.
[current-eventspace (make-eventspace)])
[current-eventspace (parameterize-break
#f
(make-eventspace))])
(let ([t (bg-run->thread (run-in-bg user-process))])
(set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t))))
(set! user-thread t))