diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index fcef51338a..098a931bd2 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -2,6 +2,7 @@ (require scheme/port scheme/list + scheme/string syntax/moddep scheme/gui/dynamic) @@ -17,8 +18,8 @@ sandbox-override-collection-paths sandbox-path-permissions sandbox-security-guard - sandbox-exit-handler sandbox-network-guard + sandbox-exit-handler sandbox-make-inspector sandbox-make-logger sandbox-memory-limit @@ -117,31 +118,37 @@ (make-parameter (lambda (what . xs) (error what "network access denied: ~e" xs)))) -(define default-sandbox-guard - (let ([orig-security (current-security-guard)]) - (make-security-guard - orig-security - (lambda (what path modes) - (when path - (let ([needed (let loop ([order permission-order]) - (cond [(null? order) - (error 'default-sandbox-guard - "unknown access modes: ~e" modes)] - [(memq (car order) modes) (car order)] - [else (loop (cdr order))]))] - [bpath (parameterize ([current-security-guard orig-security]) - (path->bytes (simplify-path* path)))]) - (unless (ormap (lambda (perm) - (and (perm<=? needed (car perm)) - (regexp-match (cadr perm) bpath))) - (sandbox-path-permissions)) - (error what "`~a' access denied for ~a" - (apply string-append - (add-between (map symbol->string modes) "+")) - path))))) - (lambda args (apply (sandbox-network-guard) args))))) +(define (make-default-sandbox-guard orig-security) + (make-security-guard + orig-security + (lambda (what path modes) + (when path + (let ([needed (let loop ([order permission-order]) + (cond [(null? order) + (error 'default-sandbox-guard + "unknown access modes: ~e" modes)] + [(memq (car order) modes) (car order)] + [else (loop (cdr order))]))] + [bpath (parameterize ([current-security-guard orig-security]) + (path->bytes (simplify-path* path)))]) + (unless (ormap (lambda (perm) + (and (perm<=? needed (car perm)) + (regexp-match (cadr perm) bpath))) + (sandbox-path-permissions)) + (error what "`~a' access denied for ~a" + (string-append* (add-between (map symbol->string modes) "+")) + path))))) + (lambda args (apply (sandbox-network-guard) args)))) -(define sandbox-security-guard (make-parameter default-sandbox-guard)) +(define sandbox-security-guard + (make-parameter make-default-sandbox-guard + (lambda (x) + (if (or (security-guard? x) + (and (procedure? x) (procedure-arity-includes? x 1))) + x + (raise-type-error + 'sandbox-security-guard + "security-guard or a security-guard translator procedure" x))))) (define (default-sandbox-exit-handler _) (error 'exit "sandboxed code cannot exit")) @@ -660,7 +667,9 @@ ;; general info [current-command-line-arguments '#()] ;; restrict the sandbox context from this point - [current-security-guard (sandbox-security-guard)] + [current-security-guard + (let ([g (sandbox-security-guard)]) + (if (security-guard? g) g (g (current-security-guard))))] [exit-handler (sandbox-exit-handler)] [current-inspector ((sandbox-make-inspector))] [current-logger ((sandbox-make-logger))] diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index c76e0cb376..036d6251cd 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -414,13 +414,16 @@ done using a fake library that provides the same interface but no actual interaction. The default is @scheme[null].} -@defparam[sandbox-security-guard guard security-guard?]{ +@defparam[sandbox-security-guard guard + (or/c security-guard? (security-guard? . -> . security-guard?))]{ A parameter that determines the initial -@scheme[(current-security-guard)] for sandboxed evaluations. The -default forbids all filesystem I/O except for things in -@scheme[sandbox-path-permissions], and it uses -@scheme[sandbox-network-guard] for network connections.} +@scheme[(current-security-guard)] for sandboxed evaluations. It can +be either a security guard, or a function that constructs a security +guard from a given one. The default is a function that restricts the +access of the current security guard by forbidding all filesystem I/O +except for specifications in @scheme[sandbox-path-permissions], and it +uses @scheme[sandbox-network-guard] for network connections.} @defparam[sandbox-path-permissions perms @@ -451,12 +454,6 @@ collection libraries (including @scheme[make-evalautor] for more information.} -@defparam[sandbox-exit-handler handler (any/c . -> . any)]{ - -A parameter that determines the initial @scheme[(exit-handler)] for -sandboxed evaluations. The default handler simply throws an error.} - - @defparam[sandbox-network-guard proc (symbol? (or/c (and/c string? immutable?) #f) @@ -469,6 +466,12 @@ default @scheme[sandbox-security-guard]. The default forbids all network connection.} +@defparam[sandbox-exit-handler handler (any/c . -> . any)]{ + +A parameter that determines the initial @scheme[(exit-handler)] for +sandboxed evaluations. The default handler simply throws an error.} + + @defparam[sandbox-memory-limit limit (or/c exact-nonnegative-integer? #f)]{ A parameter that determines the total memory limit on the sandbox.