introduce deep time vs shallow time in sandbox

pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl

@@ -314,6 +314,20 @@ unrestricted configuration and add the desired restrictions.  This approach is m
 possible by the @racket[call-with-trusted-sandbox-configuration]
 function.
 
+The sandbox environment uses two notions of restricting the time that
+evaluations takes: @tech{shallow time} and @tech{deep
+time}. @deftech{Shallow time} refers to the immediate execution of an
+expression. For example, a @tech{shallow time} limit of five seconds
+would restrict @racket[(sleep 6)] and other computations that take
+longer than five seconds. @deftech{Deep time} refers to the total
+execution of the expression and all threads and sub-processes that the
+expression creates. For example, a @tech{deep time} limit of five
+seconds would restrict @racket[(thread (λ () (sleep 6)))], which
+@tech{shallow time} would not, @emph{as well as} all expressions that
+@tech{shallow time} would restrict. By default, most sandboxes only
+restrict @tech{shallow time} to facilitate expressions that use
+threads.
+
 @defproc[(call-with-trusted-sandbox-configuration [thunk (-> any)])
          any]{
 
@@ -645,15 +659,16 @@ than one block counts against the interaction limit).}
                         (or/c (>=/c 0) #f))
                 #f)]{
 
-A @tech{parameter} that determines the default limits on @italic{each} use of
+A @tech{parameter} that determines the default limits on @italic{each}
-a @racket[make-evaluator] function, including the initial evaluation
+use of a @racket[make-evaluator] function, including the initial
-of the input program.  Its value should be a list of two numbers;
+evaluation of the input program.  Its value should be a list of two
-where the first is a timeout value in seconds, and the second is a
+numbers; where the first is a @tech{shallow time} value in seconds,
-memory limit in megabytes (note that they don't have to be integers).
+and the second is a memory limit in megabytes (note that they don't
-Either one can be @racket[#f] for disabling the corresponding limit;
+have to be integers).  Either one can be @racket[#f] for disabling the
-alternately, the parameter can be set to @racket[#f] to disable all
+corresponding limit; alternately, the parameter can be set to
-per-evaluation limits (useful in case more limit kinds are available
+@racket[#f] to disable all per-evaluation limits (useful in case more
-in future versions). The default is @racket[(list 30 20)].
+limit kinds are available in future versions). The default is
+@racket[(list 30 20)].
 
 Note that these limits apply to the creation of the sandbox
 environment too --- even @racket[(make-evaluator 'racket/base)] can
@@ -826,8 +841,8 @@ for the whole sandbox.)}
          void?]{
 
 Changes the per-expression limits that @racket[evaluator] uses to
-@racket[sec] seconds and @racket[mb] megabytes (either one can be
+@racket[secs] seconds of @tech{shallow time} and @racket[mb]
-@racket[#f], indicating no limit).
+megabytes (either one can be @racket[#f], indicating no limit).
 
 This procedure should be used to modify an existing evaluator limits,
 because changing the @racket[sandbox-eval-limits] parameter does not
@@ -989,12 +1004,12 @@ checked at the time that a sandbox evaluator is created.}
 
 Executes the given @racket[thunk] with memory and time restrictions:
 if execution consumes more than @racket[mb] megabytes or more than
-@racket[sec] seconds, then the computation is aborted and the
+@racket[secs] @tech{shallow time} seconds, then the computation is
-@exnraise[exn:fail:resource].  Otherwise the result of the thunk is
+aborted and the @exnraise[exn:fail:resource].  Otherwise the result of
-returned as usual (a value, multiple values, or an exception).  Each
+the thunk is returned as usual (a value, multiple values, or an
-of the two limits can be @racket[#f] to indicate the absence of a
+exception).  Each of the two limits can be @racket[#f] to indicate the
-limit. See also @racket[custodian-limit-memory] for information on
+absence of a limit. See also @racket[custodian-limit-memory] for
-memory limits.
+information on memory limits.
 
 Sandboxed evaluators use @racket[call-with-limits], according to the
 @racket[sandbox-eval-limits] setting and uses of
@@ -1002,19 +1017,29 @@ Sandboxed evaluators use @racket[call-with-limits], according to the
 timeouts and memory problems. Use @racket[call-with-limits] directly
 only to limit a whole testing session, instead of each expression.}
 
-
 @defform[(with-limits sec-expr mb-expr body ...)]{
 
 A macro version of @racket[call-with-limits].}
 
+@defproc[(call-with-deep-time-limit [secs exact-nonnegative-integer?]
+                                    [thunk (-> any)])
+         any]{
+ Executes the given @racket[thunk] with @tech{deep time} restrictions.
+}
+
+@defform[(with-deep-time-limit secs-expr body ...)]{
+
+A macro version of @racket[call-with-deep-time-limit].}
 
 @defproc*[([(exn:fail:resource? [v any/c]) boolean?]
            [(exn:fail:resource-resource [exn exn:fail:resource?])
-            (or/c 'time 'memory)])]{
+            (or/c 'time 'memory 'deep-time)])]{
 
 A predicate and accessor for exceptions that are raised by
-@racket[call-with-limits].  The @racket[resource] field holds a symbol,
+@racket[call-with-limits].  The @racket[resource] field holds a
-either @racket['time] or @racket['memory].}
+symbol, representing the resource that was expended. @racket['time] is
+used for @tech{shallow time} and @racket['deep-time] is used for
+@tech{deep time}.}
 
 @; ----------------------------------------------------------------------
 

pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt

@@ -0,0 +1,51 @@
+#lang racket/base
+(require racket/sandbox)
+
+(define (exn:fail:resource:time? x)
+  (and (exn:fail:resource? x)
+       (eq? 'deep-time (exn:fail:resource-resource x))))
+
+(module+ test
+  (require rackunit)
+
+  (define n 1)
+  (check-not-exn
+   (λ ()
+     (with-deep-time-limit
+      n
+      (sleep (sub1 n)))))
+  (check-exn
+   exn:fail:resource:time?
+   (λ ()
+     (with-deep-time-limit
+      n
+      (sleep (add1 n)))))
+  (check-exn
+   exn:fail:resource:time?
+   (λ ()
+     (with-deep-time-limit
+      n
+      (thread (λ () (sleep (add1 n)))))))
+  (check-exn
+   exn:fail:resource:time?
+   (λ ()
+     (with-deep-time-limit
+      n
+      (subprocess (current-output-port) 
+                  (current-input-port)
+                  (current-error-port)
+                  "/usr/bin/cat"))))
+  (check-exn
+   exn:fail:resource:time?
+   (λ ()
+     (with-deep-time-limit
+      n
+      (thread (λ ()
+                (thread (λ () (sleep (add1 n)))))))))
+  (check-exn
+   exn:fail:resource:time?
+   (λ ()
+     (with-deep-time-limit
+      n
+      (parameterize ([current-custodian (make-custodian)])
+        (thread (λ () (sleep (add1 n)))))))))

pkgs/sandbox-lib/racket/sandbox.rkt

@@ -52,6 +52,8 @@
          call-in-nested-thread*
          call-with-limits
          with-limits
+         call-with-deep-time-limit
+         with-deep-time-limit
          call-with-custodian-shutdown
          call-with-killing-threads
          exn:fail:sandbox-terminated?
@@ -415,6 +417,54 @@
     [(with-limits sec mb body ...)
      (call-with-limits sec mb (lambda () body ...))]))
 
+(define (custodian-managed-list* cust super)
+  (define ms (custodian-managed-list cust super))
+  (append-map
+   (λ (v)
+     (if (custodian? v)
+       (custodian-managed-list* v cust)
+       (list v)))
+   ms))
+
+(define (call-with-deep-time-limit secs thunk)
+  (define me
+    (current-custodian))
+  (define cust
+    (make-custodian me))
+  (define timeout-evt
+    (handle-evt
+     (alarm-evt (+ (current-inexact-milliseconds)
+                   (* 1000 secs)))
+     (λ (a) #f)))
+
+  (parameterize ([current-custodian cust]
+                 [current-subprocess-custodian-mode 'kill])
+    (thread thunk))
+
+  (define r
+    (let loop ()
+      (define ms (custodian-managed-list* cust me))
+      (define (thread-or-subprocess? x)
+        (or (thread? x)
+            (subprocess? x)))
+      (define ts (filter thread-or-subprocess? ms))
+      (sync
+       (if (empty? ts)
+         always-evt
+         (handle-evt
+          (apply choice-evt ts)
+          (λ (_)
+            (loop))))
+       timeout-evt)))
+  (custodian-shutdown-all cust)
+  (unless r
+    (raise (make-exn:fail:resource (format "call-with-deep-time-limit: out of ~a" r)
+                                   (current-continuation-marks)
+                                   'deep-time))))
+
+(define-syntax-rule (with-deep-time-limit sec body ...)
+  (call-with-deep-time-limit sec (λ () body ...)))
+
 ;; other resource utilities
 
 (define (call-with-custodian-shutdown thunk)