* sandbox-security-guard can now be a function that translates a given

security guard to a new one
* this is now used for the default to avoid grabbing the global
  security guard

svn: r12828

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
+(define (make-default-sandbox-guard orig-security)
-  (let ([orig-security (current-security-guard)])
+  (make-security-guard
-    (make-security-guard
+   orig-security
-     orig-security
+   (lambda (what path modes)
-     (lambda (what path modes)
+     (when path
-       (when path
+       (let ([needed (let loop ([order permission-order])
-         (let ([needed (let loop ([order permission-order])
+                       (cond [(null? order)
-                         (cond [(null? order)
+                              (error 'default-sandbox-guard
-                                (error 'default-sandbox-guard
+                                     "unknown access modes: ~e" modes)]
-                                       "unknown access modes: ~e" modes)]
+                             [(memq (car order) modes) (car order)]
-                               [(memq (car order) modes) (car order)]
+                             [else (loop (cdr order))]))]
-                               [else (loop (cdr order))]))]
+             [bpath (parameterize ([current-security-guard orig-security])
-               [bpath (parameterize ([current-security-guard orig-security])
+                      (path->bytes (simplify-path* path)))])
-                        (path->bytes (simplify-path* path)))])
+         (unless (ormap (lambda (perm)
-           (unless (ormap (lambda (perm)
+                          (and (perm<=? needed (car perm))
-                            (and (perm<=? needed (car perm))
+                               (regexp-match (cadr perm) bpath)))
-                                 (regexp-match (cadr perm) bpath)))
+                        (sandbox-path-permissions))
-                          (sandbox-path-permissions))
+           (error what "`~a' access denied for ~a"
-             (error what "`~a' access denied for ~a"
+                  (string-append* (add-between (map symbol->string modes) "+"))
-                    (apply string-append
+                  path)))))
-                           (add-between (map symbol->string modes) "+"))
+   (lambda args (apply (sandbox-network-guard) args))))
-                    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))]

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
+@scheme[(current-security-guard)] for sandboxed evaluations.  It can
-default forbids all filesystem I/O except for things in
+be either a security guard, or a function that constructs a security
-@scheme[sandbox-path-permissions], and it uses
+guard from a given one.  The default is a function that restricts the
-@scheme[sandbox-network-guard] for network connections.}
+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.