From 8b501f674507821c7f26531374feb91b87fe08f2 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 30 Aug 2013 07:31:15 -0600
Subject: [PATCH] racket/sandbox: add `sandbox-run-submodules`

---
 .../scribblings/reference/sandbox.scrbl        |  7 +++++++
 .../racket-test/tests/racket/sandbox.rktl      | 18 ++++++++++++++++++
 pkgs/sandbox-lib/racket/sandbox.rkt            |  9 ++++++++-
 3 files changed, 33 insertions(+), 1 deletion(-)

diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl
index 146ca2225e..c70bfc45bd 100644
--- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl
+++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl
@@ -730,6 +730,13 @@ that follows.  Another useful function for this is
 other resources intact.}
 
 
+@defparam[sandbox-run-submodules submod-syms (list/c symbol?)]{
+
+A @tech{parameter} that determines submodules to run when a sandbox is
+created by @racket[make-module-evaluator]. The parameter's default
+value is the empty list.}
+
+
 @defparam[sandbox-make-inspector make (-> inspector?)]{
 
 A @tech{parameter} that determines the (nullary) procedure that is used to
diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl
index 5795e24271..29c3ac99af 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl
@@ -296,6 +296,24 @@
    x => 1
    (define x 2) =err> "cannot re-define a constant"
 
+   ;; submodules
+   --top--
+   (parameterize ([sandbox-run-submodules '(go)])
+     (make-module-evaluator! '(module foo racket/base
+                                (define x 1)
+                                (define (set-x! v) (set! x v))
+                                (module+ go (set-x! 2)))))
+   --eval--
+   x => 2
+   --top--
+   (parameterize ([sandbox-run-submodules '(not-there)])
+     (make-module-evaluator! '(module foo racket/base
+                                (define x 1)
+                                (define (set-x! v) (set! x v))
+                                (module+ go (set-x! 2)))))
+   --eval--
+   x => 1
+
    ;; `for-syntax' is allowed in #:requires:
    --top--
    (make-evaluator! 'scheme/base #:requires '((for-syntax racket/base)))
diff --git a/pkgs/sandbox-lib/racket/sandbox.rkt b/pkgs/sandbox-lib/racket/sandbox.rkt
index 41fe5c2d94..4fe31764ad 100644
--- a/pkgs/sandbox-lib/racket/sandbox.rkt
+++ b/pkgs/sandbox-lib/racket/sandbox.rkt
@@ -34,6 +34,7 @@
          sandbox-eval-limits
          sandbox-eval-handlers
          sandbox-propagate-exceptions
+         sandbox-run-submodules
          call-with-trusted-sandbox-configuration
          evaluator-alive?
          kill-evaluator
@@ -81,6 +82,7 @@
 (define sandbox-propagate-breaks (make-parameter #t))
 (define sandbox-coverage-enabled (make-parameter #f))
 (define sandbox-propagate-exceptions (make-parameter #t))
+(define sandbox-run-submodules (make-parameter null))
 
 (define (call-with-trusted-sandbox-configuration thunk)
   (parameterize ([sandbox-propagate-breaks    #t]
@@ -615,7 +617,7 @@
 (define orig-code-inspector (variable-reference->module-declaration-inspector
                              (#%variable-reference)))
 
-(define (evaluate-program program limit-thunk uncovered!)
+(define (evaluate-program program limit-thunk submod-names uncovered!)
   (when uncovered!
     (parameterize ([current-code-inspector orig-code-inspector])
       (eval `(,#'#%require racket/private/sandbox-coverage))))
@@ -626,6 +628,9 @@
        (let ([mod #'mod])
          (lambda ()
            (eval `(,#'require (quote ,mod)))
+           (for ([submod-name (in-list submod-names)])
+             (eval `(when (module-declared? '(submod (quote ,mod) ,submod-name) #f)
+                      (dynamic-require '(submod (quote ,mod) ,submod-name) #f))))
            (module->namespace `(quote ,(syntax-e mod)))))]
       [_else #f]))
   ;; the actual evaluation happens under the specified limits
@@ -711,6 +716,7 @@
   (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 submod-names (sandbox-run-submodules))
   (define (limit-thunk thunk)
     (define sec (and limits (car limits)))
     (define mb  (and limits (cadr limits)))
@@ -767,6 +773,7 @@
              (when coverage? (set! default-coverage-source-filter src))
              prog)
            limit-thunk
+           submod-names
            (and coverage? (lambda (es+get) (set! uncovered es+get))))))
        (channel-put result-ch 'ok))
      (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler