From 4c7e319cd2cfea13b5a83ad3f97a7710ed75f644 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 4 Sep 2012 15:10:09 -0400 Subject: [PATCH] Put sandbox management in its own file. To avoid circular dependencies. --- .../typed-racket/optimizer/tool/profiling.rkt | 2 +- .../typed-racket/optimizer/tool/report.rkt | 73 +------------------ .../typed-racket/optimizer/tool/sandbox.rkt | 70 ++++++++++++++++++ 3 files changed, 75 insertions(+), 70 deletions(-) create mode 100644 collects/typed-racket/optimizer/tool/sandbox.rkt diff --git a/collects/typed-racket/optimizer/tool/profiling.rkt b/collects/typed-racket/optimizer/tool/profiling.rkt index 99752ca869..0e545b13de 100644 --- a/collects/typed-racket/optimizer/tool/profiling.rkt +++ b/collects/typed-racket/optimizer/tool/profiling.rkt @@ -2,7 +2,7 @@ (require profile/analyzer racket/gui/base) -(require "report.rkt") +(require "sandbox.rkt") (provide generate-profile) diff --git a/collects/typed-racket/optimizer/tool/report.rkt b/collects/typed-racket/optimizer/tool/report.rkt index 7bf0fc8243..c5d9ccbb13 100644 --- a/collects/typed-racket/optimizer/tool/report.rkt +++ b/collects/typed-racket/optimizer/tool/report.rkt @@ -1,17 +1,16 @@ #lang racket/base -(require racket/class racket/gui/base racket/match racket/port racket/list - unstable/syntax racket/sandbox +(require racket/class racket/gui/base racket/match racket/list + unstable/syntax typed-racket/optimizer/logging - "logging.rkt" "mzc.rkt") + "logging.rkt" "mzc.rkt" "sandbox.rkt") (provide (struct-out report-entry) (struct-out sub-report-entry) (struct-out opt-report-entry) (struct-out missed-opt-report-entry) generate-report - collapse-report - run-inside-optimization-coach-sandbox) + collapse-report) ;; Similar to the log-entry family of structs, but geared towards GUI display. ;; Also designed to contain info for multiple overlapping log entries. @@ -32,70 +31,6 @@ (generate-log this)))) -(define (log-output in done-chan) - (let loop () - (sync (handle-evt - (read-line-evt in 'linefeed) - (lambda (line) - (cond [(eof-object? line) (channel-put done-chan 'done)] - [else - (log-warning - (format "Optimization Coach Program Output: ~a" line)) - (loop)])))))) - -(define (run-inside-optimization-coach-sandbox this thunk) - (call-with-trusted-sandbox-configuration - (lambda () - (define port-name (send this get-port-name)) - ;; If the sandboxed program produces any output, log it as `warning'. - ;; Mimics what check-syntax does. - (define log-output? (log-level? (current-logger) 'warning)) - (define-values (log-in log-out) - (if log-output? (make-pipe) (values #f (open-output-nowhere)))) - (define log-done-chan (make-channel)) - (when log-output? (thread (lambda () (log-output log-in log-done-chan)))) - ;; Set up the environment. - (begin0 - (parameterize - ([current-namespace (make-base-namespace)] - [current-load-relative-directory - (if (path-string? port-name) - (let-values ([(base name _) (split-path port-name)]) - base) - (current-load-relative-directory))] - [read-accept-reader #t] - [current-output-port log-out] - [current-error-port log-out]) - (thunk)) - (when log-output? - (close-output-port log-out) - (sync log-done-chan)))))) - -;; Returns a predicate that, given a path, returns whether it corresponds -;; to the right file. -(define (make-file-predicate this) - (define portname (send this get-port-name)) - (define unsaved-file? - (and (symbol? portname) - (regexp-match #rx"^unsaved-editor" (symbol->string portname)))) - (define good-portname-cache #f) - (lambda (path) ; (or/c path? #f) - (cond [(and good-portname-cache ; cache is populated - (equal? path good-portname-cache)) - #t] - [good-portname-cache ; cache is populated, but we have the wrong file - #f] - [unsaved-file? - ;; we assume that any log entry without a filename comes from - ;; the unsaved editor - (not path)] - ;; no cache, ask directly - [(send this port-name-matches? path) - (set! good-portname-cache path) ; populate cache - #t] - [else ; different file - #f]))) - (define (generate-log this) (define file-predicate (make-file-predicate this)) (define input (open-input-text-editor this)) diff --git a/collects/typed-racket/optimizer/tool/sandbox.rkt b/collects/typed-racket/optimizer/tool/sandbox.rkt new file mode 100644 index 0000000000..eb657842cc --- /dev/null +++ b/collects/typed-racket/optimizer/tool/sandbox.rkt @@ -0,0 +1,70 @@ +#lang racket/base + +(require racket/sandbox racket/port racket/class) + +(provide run-inside-optimization-coach-sandbox + make-file-predicate) + +(define (log-output in done-chan) + (let loop () + (sync (handle-evt + (read-line-evt in 'linefeed) + (lambda (line) + (cond [(eof-object? line) (channel-put done-chan 'done)] + [else + (log-warning + (format "Optimization Coach Program Output: ~a" line)) + (loop)])))))) + +(define (run-inside-optimization-coach-sandbox this thunk) + (call-with-trusted-sandbox-configuration + (lambda () + (define port-name (send this get-port-name)) + ;; If the sandboxed program produces any output, log it as `warning'. + ;; Mimics what check-syntax does. + (define log-output? (log-level? (current-logger) 'warning)) + (define-values (log-in log-out) + (if log-output? (make-pipe) (values #f (open-output-nowhere)))) + (define log-done-chan (make-channel)) + (when log-output? (thread (lambda () (log-output log-in log-done-chan)))) + ;; Set up the environment. + (begin0 + (parameterize + ([current-namespace (make-base-namespace)] + [current-load-relative-directory + (if (path-string? port-name) + (let-values ([(base name _) (split-path port-name)]) + base) + (current-load-relative-directory))] + [read-accept-reader #t] + [current-output-port log-out] + [current-error-port log-out]) + (thunk)) + (when log-output? + (close-output-port log-out) + (sync log-done-chan)))))) + +;; Returns a predicate that, given a path, returns whether it corresponds +;; to the right file. +(define (make-file-predicate this) + (define portname (send this get-port-name)) + (define unsaved-file? + (and (symbol? portname) + (regexp-match #rx"^unsaved-editor" (symbol->string portname)))) + (define good-portname-cache #f) + (lambda (path) ; (or/c path? #f) + (cond [(and good-portname-cache ; cache is populated + (equal? path good-portname-cache)) + #t] + [good-portname-cache ; cache is populated, but we have the wrong file + #f] + [unsaved-file? + ;; we assume that any log entry without a filename comes from + ;; the unsaved editor + (not path)] + ;; no cache, ask directly + [(send this port-name-matches? path) + (set! good-portname-cache path) ; populate cache + #t] + [else ; different file + #f])))