From c62595772fcc6231d4175c54d9a7f0f469a0c4cb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 01:07:00 +0000 Subject: [PATCH] Finally enabled using a sub code-inspector properly, with a new 'read-bytecode permission mode. Added tests and (crappily) documented. svn: r12846 --- collects/scheme/sandbox.ss | 97 +++++++++---- collects/scribblings/reference/sandbox.scrbl | 34 ++++- collects/tests/mzscheme/sandbox.ss | 145 ++++++++++++------- 3 files changed, 185 insertions(+), 91 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 4091527e49..64f89865a0 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -94,9 +94,14 @@ [(string? path) (string->path path)] [else path])))))) -(define permission-order '(execute write delete read exists)) +;; 'read-bytecode is special, it's higher than 'read, but not lower than +;; 'delete. +(define permission-order '(execute write delete read-bytecode read exists)) (define (perm<=? p1 p2) - (memq p1 (memq p2 permission-order))) + (or (eq? p1 p2) + (and (not (eq? 'read-bytecode p1)) + (memq p1 (memq p2 permission-order)) + #t))) ;; gets a path (can be bytes/string), returns a regexp for that path that ;; matches also subdirs (if it's a directory) @@ -117,6 +122,29 @@ (map (lambda (perm) (list (car perm) (path->bregexp (cadr perm)))) new)))) +;; compresses the (sandbox-path-permissions) value to a "compressed" list of +;; (permission regexp ...) where each permission appears exactly once (so it's +;; quicker to test it later, no need to scan the whole permission list). +(define compressed-path-permissions + (let ([t (make-weak-hasheq)]) + (define (compress-permissions ps) + (map (lambda (perm) + (let* ([ps (filter (lambda (p) (perm<=? perm (car p))) ps)] + [ps (remove-duplicates (map cadr ps))]) + (cons perm ps))) + permission-order)) + (lambda () + (let ([ps (sandbox-path-permissions)]) + (or (hash-ref t ps #f) + (let ([c (compress-permissions ps)]) (hash-set! t ps c) c)))))) + +;; similar to the security guard, only with a single mode for simplification; +;; assumes valid mode and simplified path +(define (check-sandbox-path-permissions path needed) + (let ([bpath (path->bytes path)] + [perms (compressed-path-permissions)]) + (ormap (lambda (rx) (regexp-match? rx bpath)) (cdr (assq needed perms))))) + (define sandbox-network-guard (make-parameter (lambda (what . xs) (error what "network access denied: ~e" xs)))) @@ -127,16 +155,17 @@ orig-security (lambda (what path modes) (when path - (let ([needed (car (or (for/or ([p (in-list permission-order)]) - (memq p modes)) - (error 'default-sandbox-guard - "unknown access modes: ~e" modes)))] - [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)) + (let ([spath (parameterize ([current-security-guard orig-security]) + (simplify-path* path))] + [maxperm + ;; assumes that the modes are valid (ie, in the above list) + (cond [(null? modes) (error 'default-sandbox-guard + "got empty mode list for ~e and ~e" + what path)] + [(null? (cdr modes)) (car modes)] ; common case + [else (foldl (lambda (x max) (if (perm<=? max x) x max)) + (car modes) (cdr modes))])]) + (unless (check-sandbox-path-permissions spath maxperm) (error what "`~a' access denied for ~a" (string-append* (add-between (map symbol->string modes) "+")) path))))) @@ -168,8 +197,8 @@ (append (map (lambda (p) `(read ,(path->bytes p))) paths) (module-specs->path-permissions require-perms)))) -;; computes permissions that are needed for require specs (`read' for all -;; files and "compiled" subdirs, `exists' for the base-dir) +;; computes permissions that are needed for require specs (`read-bytecode' for +;; all files and "compiled" subdirs, `exists' for the base-dir) (define (module-specs->path-permissions mods) (define paths (module-specs->non-lib-paths mods)) (define bases @@ -180,8 +209,8 @@ (let ([base (simplify-path* base)]) (loop (cdr paths) (if (member base bases) bases (cons base bases)))))))) - (append (map (lambda (p) `(read ,p)) paths) - (map (lambda (b) `(read ,(build-path b "compiled"))) bases) + (append (map (lambda (p) `(read-bytecode ,p)) paths) + (map (lambda (b) `(read-bytecode ,(build-path b "compiled"))) bases) (map (lambda (b) `(exists ,b)) bases))) ;; takes a module-spec list and returns all module paths that are needed @@ -526,6 +555,7 @@ (define (make-evaluator* init-hook allow program-maker) (define orig-code-inspector (current-code-inspector)) + (define orig-security-guard (current-security-guard)) (define orig-cust (current-custodian)) (define memory-cust (make-custodian orig-cust)) (define memory-cust-box (make-custodian-box memory-cust #t)) @@ -707,7 +737,7 @@ (append (sandbox-override-collection-paths) (current-library-collection-paths)))] [sandbox-path-permissions - (append (map (lambda (p) `(read ,p)) + (append (map (lambda (p) `(read-bytecode ,p)) (current-library-collection-paths)) (compute-permissions allow) (sandbox-path-permissions))] @@ -716,24 +746,31 @@ ;; restrict the sandbox context from this point [current-security-guard (let ([g (sandbox-security-guard)]) (if (security-guard? g) g (g)))] + [current-logger ((sandbox-make-logger))] + [current-inspector ((sandbox-make-inspector))] + [current-code-inspector ((sandbox-make-code-inspector))] + ;; The code inspector serves two purposes -- making sure that only trusted + ;; byte-code is loaded, and avoiding using protected module bindings, like + ;; the foreign library's `unsafe!'. We control the first through the path + ;; permissions -- using the 'read-bytecode permissionn level, so this + ;; handler just checks for that permission then goes on to load the file + ;; using the original inspector. + [current-load/use-compiled + (let ([handler (current-load/use-compiled)]) + (lambda (path modname) + (if (check-sandbox-path-permissions + (parameterize ([current-security-guard orig-security-guard]) + (simplify-path* path)) + 'read-bytecode) + (parameterize ([current-code-inspector orig-code-inspector]) + (handler path modname)) + ;; otherwise, just let the old handler throw a proper error + (handler path modname))))] [exit-handler (let ([h (sandbox-exit-handler)]) (if (eq? h default-sandbox-exit-handler) (lambda _ (terminated! 'exited) (user-kill)) h))] - [current-inspector ((sandbox-make-inspector))] - [current-logger ((sandbox-make-logger))] - [current-code-inspector (make-inspector)] - ;; The code inspector serves two purposes -- making sure that only trusted - ;; byte-code is loaded, and avoiding using protected moduel bindings, like - ;; the foreign library's `unsafe!'. We don't need the first because we - ;; control it indirectly through the security guard, so this handler makes - ;; sure that byte-code is loaded using the original inspector. - [current-load/use-compiled - (let ([handler (current-load/use-compiled)]) - (lambda (path modname) - (parameterize ([current-code-inspector orig-code-inspector]) - (handler path modname))))] ;; Note the above definition of `current-eventspace': in MzScheme, it ;; is an unused parameter. Also note that creating an eventspace ;; starts a thread that will eventually run the callback code (which diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 229f638c82..809e0d930d 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -443,7 +443,7 @@ specifications in @scheme[sandbox-path-permissions], and it uses @defparam[sandbox-path-permissions perms - (listof (list/c (or/c 'execute 'write 'delete 'read 'exists) + (listof (list/c (or/c 'execute 'write 'delete 'read-bytecode 'read 'exists) (or/c byte-regexp? bytes? string? path?)))]{ A parameter that configures the behavior of the default sandbox @@ -453,9 +453,9 @@ each is an access mode and a byte-regexp for paths that are granted this access. The access mode symbol is one of: @scheme['execute], @scheme['write], -@scheme['delete], @scheme['read], or @scheme['exists]. These symbols are -in decreasing order: each implies access for the following modes too -(e.g., @scheme['read] allows reading or checking for existence). +@scheme['delete], @scheme['read], or @scheme['exists]. These symbols +are in decreasing order: each implies access for the following modes +too (e.g., @scheme['read] allows reading or checking for existence). The path regexp is used to identify paths that are granted access. It can also be given as a path (or a string or a byte string), which is @@ -463,9 +463,25 @@ can also be given as a path (or a string or a byte string), which is to a regexp that allows the path and sub-directories; e.g., @scheme["/foo/bar"] applies to @scheme["/foo/bar/baz"]. +An additional mode symbol, @scheme['read-bytecode], is not part of the +linear order of these modes. Specifying this mode is similar to +specifying @scheme['read], but it is not implied by any other mode. +(For example, even if you specify @scheme['write] for a certain path, +you need to also specify @scheme['read-bytecode] to grant this +permission.) The sandbox usually works in the context of a lower code +inspector (see @scheme[sandbox-make-code-inspector]) which prevents +loading of untrusted bytecode files --- the sandbox is set-up to allow +loading bytecode from files that are specified with +@scheme['read-bytecode]. This specification is given by default to +the PLT collection hierarchy (including user-specific libraries) and +to libraries that are explicitly specified in an @scheme[#:allow-read] +argument. (Note that this applies for loading bytecode files only, +under a lower code inspector it is still impossible to use protected +module bindings (see @secref["modprotect"]).) + The default value is null, but when an evaluator is created, it is -augmented by @scheme['read] permissions that make it possible to use -collection libraries (including +augmented by @scheme['read-bytecode] permissions that make it possible +to use collection libraries (including @scheme[sandbox-override-collection-paths]). See @scheme[make-evalautor] for more information.} @@ -582,7 +598,11 @@ an evaluator, and the default parameter value is A parameter that determines the procedure used to create the code inspector for sandboxed evaluation. The procedure is called when initializing an evaluator, and the default parameter value is -@scheme[make-inspector].} +@scheme[make-inspector]. The @scheme[current-load/use-compiled] +handler is setup to still allow loading of bytecode files under the +original code inspector when @scheme[sandbox-path-permissions] allows +it through a @scheme['read-bytecode] mode symbol, to make it possible +to load libraries.} @defparam[sandbox-make-logger make (-> logger?)]{ diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 855d14c798..4077bb651e 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -275,59 +275,94 @@ ;; limited FS access, allowed for requires --top-- - (let* ([tmp (find-system-path 'temp-dir)] - [schemelib (path->string (collection-path "scheme"))] - [list-lib (path->string (build-path schemelib "list.ss"))] - [test-lib (path->string (build-path tmp "sandbox-test.ss"))]) - (t --top-- - (set! ev (make-evaluator 'scheme/base)) - --eval-- - ;; reading from collects is allowed - (list (directory-list ,schemelib)) - (file-exists? ,list-lib) => #t - (input-port? (open-input-file ,list-lib)) => #t - ;; writing is forbidden - (open-output-file ,list-lib) =err> "`write' access denied" - ;; reading from other places is forbidden - (directory-list ,tmp) =err> "`read' access denied" - ;; no network too - (require scheme/tcp) - (tcp-listen 12345) =err> "network access denied" - --top-- - ;; reading from a specified require is fine - (with-output-to-file test-lib - (lambda () - (printf "~s\n" '(module sandbox-test scheme/base - (define x 123) (provide x)))) - #:exists 'replace) - (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) - --eval-- - x => 123 - (length (with-input-from-file ,test-lib read)) => 5 - ;; the directory is still not kosher - (directory-list ,tmp) =err> "`read' access denied" - --top-- - ;; should work also for module evaluators - ;; --> NO! Shouldn't make user code require whatever it wants - ;; (set! ev (make-evaluator `(module foo scheme/base - ;; (require (file ,test-lib))))) - ;; --eval-- - ;; x => 123 - ;; (length (with-input-from-file ,test-lib read)) => 5 - ;; ;; the directory is still not kosher - ;; (directory-list tmp) =err> "file access denied" - --top-- - ;; explicitly allow access to tmp - (set! ev (parameterize ([sandbox-path-permissions - `((read ,tmp) - ,@(sandbox-path-permissions))]) - (make-evaluator 'scheme/base))) - --eval-- - (length (with-input-from-file ,test-lib read)) => 5 - (list? (directory-list ,tmp)) - (open-output-file ,(build-path tmp "blah")) =err> "access denied" - (delete-directory ,(build-path tmp "blah")) =err> "access denied") - (delete-file test-lib)) + (let* ([tmp (make-temporary-file "sandboxtest~a" 'directory)] + [strpath (lambda xs (path->string (apply build-path xs)))] + [schemelib (strpath (collection-path "scheme"))] + [list-lib (strpath schemelib "list.ss")] + [list-zo (strpath schemelib "compiled" "list_ss.zo")] + [test-lib (strpath tmp "sandbox-test.ss")] + [test-zo (strpath tmp "compiled" "sandbox-test_ss.zo")] + [test2-lib (strpath tmp "sandbox-test2.ss")] + [test2-zo (strpath tmp "compiled" "sandbox-test2_ss.zo")]) + (t --top-- + (set! ev (make-evaluator 'scheme/base)) + --eval-- + ;; reading from collects is allowed + (list? (directory-list ,schemelib)) + (file-exists? ,list-lib) => #t + (input-port? (open-input-file ,list-lib)) => #t + ;; writing is forbidden + (open-output-file ,list-lib) =err> "`write' access denied" + ;; reading from other places is forbidden + (directory-list ,tmp) =err> "`read' access denied" + ;; no network too + (require scheme/tcp) + (tcp-listen 12345) =err> "network access denied" + --top-- + ;; reading from a specified require is fine + (with-output-to-file test-lib + (lambda () + (printf "~s\n" '(module sandbox-test scheme/base + (define x 123) (provide x))))) + (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) + --eval-- + x => 123 + (length (with-input-from-file ,test-lib read)) => 5 + ;; the directory is still not kosher + (directory-list ,tmp) =err> "`read' access denied" + --top-- + ;; should work also for module evaluators + ;; --> NO! Shouldn't make user code require whatever it wants + ;; (set! ev (make-evaluator `(module foo scheme/base + ;; (require (file ,test-lib))))) + ;; --eval-- + ;; x => 123 + ;; (length (with-input-from-file ,test-lib read)) => 5 + ;; ;; the directory is still not kosher + ;; (directory-list tmp) =err> "file access denied" + --top-- + ;; explicitly allow access to tmp, and write access to a single file + (make-directory (build-path tmp "compiled")) + (set! ev (parameterize ([sandbox-path-permissions + `((read ,tmp) + (write ,test-zo) + ,@(sandbox-path-permissions))]) + (make-evaluator 'scheme/base))) + --eval-- + (length (with-input-from-file ,test-lib read)) => 5 + (list? (directory-list ,tmp)) + (open-output-file ,(build-path tmp "blah")) =err> "access denied" + (delete-directory ,(build-path tmp "blah")) =err> "access denied" + (list? (directory-list ,schemelib)) + ;; we can read/write/delete list-zo, but we can't load bytecode from + ;; it due to the code inspector + (copy-file ,list-zo ,test-zo) => (void) + (copy-file ,test-zo ,list-zo) =err> "access denied" + (load/use-compiled ,test-lib) => (void) + (require 'list) =err> "access from an uncertified context" + (delete-file ,test-zo) => (void) + (delete-file ,test-lib) =err> "`delete' access denied" + --top-- + ;; a more explicit test of bytcode loading, allowing rw access to the + ;; complete tmp directory, but read-bytecode only for test2-lib + (set! ev (parameterize ([sandbox-path-permissions + `((write ,tmp) + (read-bytecode ,test2-lib) + ,@(sandbox-path-permissions))]) + (make-evaluator 'scheme/base))) + --eval-- + (define (cp from to) + (when (file-exists? to) (delete-file to)) + (copy-file from to)) + (cp ,list-lib ,test-lib) (cp ,list-zo ,test-zo) + (cp ,list-lib ,test2-lib) (cp ,list-zo ,test2-zo) + ;; bytecode from test-lib is bad, even when we can read/write to it + (load/use-compiled ,test-zo) + (require 'list) =err> "access from an uncertified context" + ;; bytecode from test2-lib is explicitly allowed + (load/use-compiled ,test2-lib) + (require 'list) => (void)) + ((dynamic-require 'scheme/file 'delete-directory/files) tmp)) ;; languages and requires --top-- @@ -391,7 +426,9 @@ [sandbox-memory-limit 5] [sandbox-eval-limits '(0.25 1/2)]) (make-evaluator 'scheme/base))) - ;; GCing is needed to allow these to happen + ;; GCing is needed to allow these to happen (note: the memory limit is very + ;; tight here, this test usually fails if the sandbox library is not + ;; compiled) --eval-- (display (make-bytes 400000 65)) (collect-garbage) --top-- (bytes-length (get-output ev)) => 400000 --eval-- (display (make-bytes 400000 65)) (collect-garbage)