diff --git a/NEWS b/NEWS index 326617fd8..dfcd4fe0d 100644 --- a/NEWS +++ b/NEWS @@ -103,6 +103,12 @@ have 'sh' in /bin. ** -Werror=array-bounds is now added to CFLAGS when available This catches +** Add option to disable time limit in 'eval-in-sandbox' + +eval-in-sandbox is modified so that #:time-limit accepts #f to disable +the time limit. Systems without SIGALRM can use eval-in-sandbox if the +time limit is disabled. + * Bug fixes ** `basename` now checks the suffix against the base name, not the full path diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 68bf38e54..1877dcca6 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -1396,10 +1396,10 @@ The main sandbox interface is @code{eval-in-sandbox}. [#:bindings all-pure-bindings] @ [#:module (make-sandbox-module bindings)] @ [#:sever-module? #t] -Evaluate the Scheme expression @var{exp} within an isolated -"sandbox". Limit its execution to @var{time-limit} seconds of -wall-clock time, and limit its allocation to @var{allocation-limit} -bytes. +Evaluate the Scheme expression @var{exp} within an isolated "sandbox". +When @var{time-limit} is a number and is not @code{#f}, limit its +execution to @var{time-limit} seconds of wall-clock time. Limit its +allocation to @var{allocation-limit} bytes. The evaluation will occur in @var{module}, which defaults to the result of calling @code{make-sandbox-module} on @var{bindings}, which itself diff --git a/module/ice-9/sandbox.scm b/module/ice-9/sandbox.scm index 601485cce..aa2e02132 100644 --- a/module/ice-9/sandbox.scm +++ b/module/ice-9/sandbox.scm @@ -6,18 +6,18 @@ ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. -;;;; +;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Commentary: -;;; +;;; ;;; Code: (define-module (ice-9 sandbox) @@ -217,9 +217,9 @@ respectively." (module (make-sandbox-module bindings)) (sever-module? #t)) "Evaluate the Scheme expression @var{exp} within an isolated -\"sandbox\". Limit its execution to @var{time-limit} seconds of -wall-clock time, and limit its allocation to @var{allocation-limit} -bytes. +\"sandbox\". When @var{time-limit} is true, limit its execution to +@var{time-limit} seconds of wall-clock time. Limit its allocation to +@var{allocation-limit} bytes. The evaluation will occur in @var{module}, which defaults to the result of calling @code{make-sandbox-module} on @var{bindings}, which itself @@ -256,10 +256,19 @@ allocation limit is exceeded, an exception will be thrown to the (dynamic-wind (lambda () #t) (lambda () - (call-with-time-and-allocation-limits - time-limit allocation-limit - (lambda () - (eval exp module)))) + (if time-limit + (call-with-time-and-allocation-limits + time-limit allocation-limit + (lambda () + (eval exp module))) + + (call-with-allocation-limit + allocation-limit + (lambda () + (eval exp module)) + (lambda () + (scm-error 'limit-exceeded "with-resource-limits" + "Allocation limit exceeded" '() #f))))) (lambda () (when sever-module? (sever-module! module))))) diff --git a/test-suite/tests/sandbox.test b/test-suite/tests/sandbox.test index 3a1653a97..96651a2b1 100644 --- a/test-suite/tests/sandbox.test +++ b/test-suite/tests/sandbox.test @@ -69,16 +69,27 @@ (define-syntax-rule (pass-if-unbound foo) (pass-if-exception (format #f "~a unavailable" 'foo) - exception:unbound-var (eval-in-sandbox 'foo)) + exception:unbound-var + (unless (defined? 'SIGALRM) (throw 'unsupported)) + (eval-in-sandbox 'foo)) ) (with-test-prefix "eval-in-sandbox" (pass-if-equal 42 - (eval-in-sandbox 42)) + (begin + (unless (defined? 'SIGALRM) + (throw 'unsupported)) + (eval-in-sandbox 42))) (pass-if-equal 'foo - (eval-in-sandbox ''foo)) + (begin + (unless (defined? 'SIGALRM) + (throw 'unsupported)) + (eval-in-sandbox ''foo))) (pass-if-equal '(1 . 2) - (eval-in-sandbox '(cons 1 2))) + (begin + (unless (defined? 'SIGALRM) + (throw 'unsupported)) + (eval-in-sandbox '(cons 1 2)))) (pass-if-unbound @@) (pass-if-unbound foo) (pass-if-unbound set!) @@ -87,9 +98,36 @@ (pass-if-unbound call-with-output-file) (pass-if-unbound vector-set!) (pass-if-equal vector-set! - (eval-in-sandbox 'vector-set! - #:bindings all-pure-and-impure-bindings)) + (begin + (unless (defined? 'SIGALRM) + (throw 'unsupported)) + (eval-in-sandbox 'vector-set! + #:bindings all-pure-and-impure-bindings))) (pass-if-exception "limit exceeded" '(limit-exceeded . "") + (unless (defined? 'SIGALRM) (throw 'unsupported)) (eval-in-sandbox '(let lp () (lp))))) +(define-syntax-rule (pass-if-unbound-no-timeout foo) + (pass-if-exception (format #f "~a unavailable" 'foo) + exception:unbound-var (eval-in-sandbox 'foo #:time-limit #f)) + ) + +(with-test-prefix "eval-in-sandbox no timeout" + (pass-if-equal 42 + (eval-in-sandbox 42 #:time-limit #f)) + (pass-if-equal 'foo + (eval-in-sandbox ''foo #:time-limit #f)) + (pass-if-equal '(1 . 2) + (eval-in-sandbox '(cons 1 2) #:time-limit #f)) + (pass-if-unbound-no-timeout @@) + (pass-if-unbound-no-timeout foo) + (pass-if-unbound-no-timeout set!) + (pass-if-unbound-no-timeout open-file) + (pass-if-unbound-no-timeout current-input-port) + (pass-if-unbound-no-timeout call-with-output-file) + (pass-if-unbound-no-timeout vector-set!) + (pass-if-equal vector-set! + (eval-in-sandbox 'vector-set! + #:bindings all-pure-and-impure-bindings + #:time-limit #f)))