Add option to disable time limit in eval-in-sandbox

On systems without SIGALRM, the other features of eval-in-sandbox
may still be useful.  This adds the option to set #:time-limit to
#f to indicate no timeout.

* NEWS: updated
* module/ice-9/sandbox.scm (eval-in-sandbox): allow #:time-limit key
    to be #f to disable time limit
* doc/ref/api-evaluation.texi (eval-in-sandbox): update documentation
* test-suite/tests/sandbox.scm ("eval-in-sandbox"): throw unsupported
    if no SIGALARM
  ("eval-in-sandbox no timeout"): new tests for eval-in-sandbox

NEWS

@@ -103,6 +103,12 @@ have 'sh' in /bin.
 ** -Werror=array-bounds is now added to CFLAGS when available
    This catches <https://bugs.gnu.org/76907>
 
+** 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

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
+Evaluate the Scheme expression @var{exp} within an isolated "sandbox".
-"sandbox".  Limit its execution to @var{time-limit} seconds of
+When @var{time-limit} is a number and is not @code{#f}, limit its
-wall-clock time, and limit its allocation to @var{allocation-limit}
+execution to @var{time-limit} seconds of wall-clock time.  Limit its
-bytes.
+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

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
+\"sandbox\".  When @var{time-limit} is true, limit its execution to
-wall-clock time, and limit its allocation to @var{allocation-limit}
+@var{time-limit} seconds of wall-clock time. Limit its allocation to
-bytes.
+@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
+      (if time-limit
-       time-limit allocation-limit
+        (call-with-time-and-allocation-limits
-       (lambda ()
+         time-limit allocation-limit
-         (eval exp module))))
+         (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)))))
 
 

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!
+      (begin
-                       #:bindings all-pure-and-impure-bindings))
+        (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)))