summaryrefslogtreecommitdiff
path: root/module/ice-9/sandbox.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/sandbox.scm')
-rw-r--r--module/ice-9/sandbox.scm1396
1 files changed, 1396 insertions, 0 deletions
diff --git a/module/ice-9/sandbox.scm b/module/ice-9/sandbox.scm
new file mode 100644
index 000000000..bbb811952
--- /dev/null
+++ b/module/ice-9/sandbox.scm
@@ -0,0 +1,1396 @@
+;;; Sandboxed evaluation of Scheme code
+
+;;; Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; 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)
+ #:use-module (ice-9 control)
+ #:use-module (ice-9 match)
+ #:use-module ((ice-9 threads) #:select (current-thread))
+ #:use-module (system vm vm)
+ #:export (call-with-time-limit
+ call-with-allocation-limit
+ call-with-time-and-allocation-limits
+
+ eval-in-sandbox
+ make-sandbox-module
+
+ alist-bindings
+ array-bindings
+ bit-bindings
+ bitvector-bindings
+ char-bindings
+ char-set-bindings
+ clock-bindings
+ core-bindings
+ error-bindings
+ fluid-bindings
+ hash-bindings
+ iteration-bindings
+ keyword-bindings
+ list-bindings
+ macro-bindings
+ nil-bindings
+ number-bindings
+ pair-bindings
+ predicate-bindings
+ procedure-bindings
+ promise-bindings
+ prompt-bindings
+ regexp-bindings
+ sort-bindings
+ srfi-4-bindings
+ string-bindings
+ symbol-bindings
+ unspecified-bindings
+ variable-bindings
+ vector-bindings
+ version-bindings
+
+ mutating-alist-bindings
+ mutating-array-bindings
+ mutating-bitvector-bindings
+ mutating-fluid-bindings
+ mutating-hash-bindings
+ mutating-list-bindings
+ mutating-pair-bindings
+ mutating-sort-bindings
+ mutating-srfi-4-bindings
+ mutating-string-bindings
+ mutating-variable-bindings
+ mutating-vector-bindings
+
+ all-pure-bindings
+ all-pure-and-impure-bindings))
+
+
+(define (call-with-time-limit limit thunk limit-reached)
+ "Call @var{thunk}, but cancel it if @var{limit} seconds of wall-clock
+time have elapsed. If the computation is cancelled, call
+@var{limit-reached} in tail position. @var{thunk} must not disable
+interrupts or prevent an abort via a @code{dynamic-wind} unwind
+handler."
+ ;; FIXME: use separate thread instead of sigalrm. If rounded limit is
+ ;; <= 0, make it 1 usec to signal immediately.
+ (let ((limit-usecs (max (inexact->exact (round (* limit 1e6))) 1))
+ (prev-sigalarm-handler #f)
+ (tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda ()
+ (dynamic-wind
+ (lambda ()
+ (set! prev-sigalarm-handler
+ (sigaction SIGALRM (lambda (sig)
+ ;; If signal handling is delayed
+ ;; until after prompt, no worries;
+ ;; the success path won the race.
+ (false-if-exception
+ (abort-to-prompt tag)))))
+ (setitimer ITIMER_REAL 0 0 0 limit-usecs))
+ thunk
+ (lambda ()
+ (setitimer ITIMER_REAL 0 0 0 0)
+ (match prev-sigalarm-handler
+ ((handler . flags)
+ (sigaction SIGALRM handler flags))))))
+ (lambda (k)
+ (limit-reached)))))
+
+(define (call-with-allocation-limit limit thunk limit-reached)
+ "Call @var{thunk}, but cancel it if @var{limit} bytes have been
+allocated. If the computation is cancelled, call @var{limit-reached} in
+tail position. @var{thunk} must not disable interrupts or prevent an
+abort via a @code{dynamic-wind} unwind handler.
+
+This limit applies to both stack and heap allocation. The computation
+will not be aborted before @var{limit} bytes have been allocated, but
+for the heap allocation limit, the check may be postponed until the next
+garbage collection.
+
+Note that as a current shortcoming, the heap size limit applies to all
+threads; concurrent allocation by other unrelated threads counts towards
+the allocation limit."
+ (define (bytes-allocated) (assq-ref (gc-stats) 'heap-total-allocated))
+ (let ((zero (bytes-allocated))
+ (tag (make-prompt-tag))
+ (thread (current-thread)))
+ (define (check-allocation)
+ (when (< limit (- (bytes-allocated) zero))
+ (system-async-mark (lambda ()
+ (false-if-exception (abort-to-prompt tag)))
+ thread)))
+ (call-with-prompt tag
+ (lambda ()
+ (dynamic-wind
+ (lambda ()
+ (add-hook! after-gc-hook check-allocation))
+ (lambda ()
+ (call-with-stack-overflow-handler
+ ;; The limit is in "words", which used to be 4 or 8 but now
+ ;; is always 8 bytes.
+ (max (floor/ limit 8) 1)
+ thunk
+ (lambda () (abort-to-prompt tag))))
+ (lambda ()
+ (remove-hook! after-gc-hook check-allocation))))
+ (lambda (k)
+ (limit-reached)))))
+
+(define (call-with-time-and-allocation-limits time-limit allocation-limit
+ thunk)
+ "Invoke @var{thunk} in a dynamic extent in which its execution is
+limited to @var{time-limit} seconds of wall-clock time, and its
+allocation to @var{allocation-limit} bytes. @var{thunk} must not
+disable interrupts or prevent an abort via a @code{dynamic-wind} unwind
+handler.
+
+If successful, return all values produced by invoking @var{thunk}. Any
+uncaught exception thrown by the thunk will propagate out. If the time
+or allocation limit is exceeded, an exception will be thrown to the
+@code{limit-exceeded} key."
+ (call-with-time-limit
+ time-limit
+ (lambda ()
+ (call-with-allocation-limit
+ allocation-limit
+ thunk
+ (lambda ()
+ (scm-error 'limit-exceeded "with-resource-limits"
+ "Allocation limit exceeded" '() #f))))
+ (lambda ()
+ (scm-error 'limit-exceeded "with-resource-limits"
+ "Time limit exceeded" '() #f))))
+
+(define (sever-module! m)
+ "Remove @var{m} from its container module."
+ (match (module-name m)
+ ((head ... tail)
+ (let ((parent (resolve-module head #f)))
+ (unless (eq? m (module-ref-submodule parent tail))
+ (error "can't sever module?"))
+ (hashq-remove! (module-submodules parent) tail)))))
+
+;; bindings := module-binding-list ...
+;; module-binding-list := interface-name import ...
+;; import := name | (exported-name . imported-name)
+;; name := symbol
+(define (make-sandbox-module bindings)
+ "Return a fresh module that only contains @var{bindings}.
+
+The @var{bindings} should be given as a list of import sets. One import
+set is a list whose car names an interface, like @code{(ice-9 q)}, and
+whose cdr is a list of imports. An import is either a bare symbol or a
+pair of @code{(@var{out} . @var{in})}, where @var{out} and @var{in} are
+both symbols and denote the name under which a binding is exported from
+the module, and the name under which to make the binding available,
+respectively."
+ (let ((m (make-fresh-user-module)))
+ (purify-module! m)
+ (module-use-interfaces! m
+ (map (match-lambda
+ ((mod-name . bindings)
+ (resolve-interface mod-name
+ #:select bindings)))
+ bindings))
+ m))
+
+(define* (eval-in-sandbox exp #:key
+ (time-limit 0.1)
+ (allocation-limit #e10e6)
+ (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.
+
+The evaluation will occur in @var{module}, which defaults to the result
+of calling @code{make-sandbox-module} on @var{bindings}, which itself
+defaults to @code{all-pure-bindings}. This is the core of the
+sandbox: creating a scope for the expression that is @dfn{safe}.
+
+A safe sandbox module has two characteristics. Firstly, it will not
+allow the expression being evaluated to avoid being cancelled due to
+time or allocation limits. This ensures that the expression terminates
+in a timely fashion.
+
+Secondly, a safe sandbox module will prevent the evaluation from
+receiving information from previous evaluations, or from affecting
+future evaluations. All combinations of binding sets exported by
+@code{(ice-9 sandbox)} form safe sandbox modules.
+
+The @var{bindings} should be given as a list of import sets. One import
+set is a list whose car names an interface, like @code{(ice-9 q)}, and
+whose cdr is a list of imports. An import is either a bare symbol or a
+pair of @code{(@var{out} . @var{in})}, where @var{out} and @var{in} are
+both symbols and denote the name under which a binding is exported from
+the module, and the name under which to make the binding available,
+respectively. Note that @var{bindings} is only used as an input to the
+default initializer for the @var{module} argument; if you pass
+@code{#:module}, @var{bindings} is unused. If @var{sever-module?} is
+true (the default), the module will be unlinked from the global module
+tree after the evaluation returns, to allow @var{mod} to be
+garbage-collected.
+
+If successful, return all values produced by @var{exp}. Any uncaught
+exception thrown by the expression will propagate out. If the time or
+allocation limit is exceeded, an exception will be thrown to the
+@code{limit-exceeded} key."
+ (dynamic-wind
+ (lambda () #t)
+ (lambda ()
+ (call-with-time-and-allocation-limits
+ time-limit allocation-limit
+ (lambda ()
+ (eval exp module))))
+ (lambda () (when sever-module? (sever-module! module)))))
+
+
+;; An evaluation-sandboxing facility is safe if:
+;;
+;; (1) every evaluation will terminate in a timely manner
+;;
+;; (2) no evaluation can affect future evaluations
+;;
+;; For (1), we impose a user-controllable time limit on the evaluation,
+;; in wall-clock time. When that limit is reached, Guile schedules an
+;; asynchronous interrupt in the sandbox that aborts the computation.
+;; For this to work, the sandboxed evaluation must not disable
+;; interrupts, and it must not prevent timely aborts via malicious "out"
+;; guards in dynamic-wind thunks.
+;;
+;; The sandbox also has an allocation limit that uses a similar cancel
+;; mechanism, but this limit is less precise as it only runs at
+;; garbage-collection time.
+;;
+;; The sandbox sets the allocation limit as the stack limit as well.
+;;
+;; For (2), the only way an evaluation can affect future evaluations is
+;; if it causes a side-effect outside its sandbox. That side effect
+;; could change the way the host or future sandboxed evaluations
+;; operate, or it could leak information to future evaluations.
+;;
+;; One means of information leakage would be the file system. Although
+;; one can imagine "safe" ways to access a file system, in practice we
+;; just prevent all access to this and other operating system facilities
+;; by not exposing the Guile primitives that access the file system,
+;; connect to networking hosts, etc. If we chose our set of bindings
+;; correctly and it is impossible to access host values other than those
+;; given to the evaluation, then we have succeeded in granting only a
+;; limited set of capabilities to the guest.
+;;
+;; To prevent information leakage we also limit other information about
+;; the host, like its hostname or the Guile build information.
+;;
+;; The guest must also not have the capability to mutate a location used
+;; by the host or by future sandboxed evaluations. Either you expose no
+;; primitives to the evaluation that can mutate locations, or you expose
+;; no mutable locations. In this sandbox we opt for a combination of
+;; the two, though the selection of bindings is up to the user. "set!"
+;; is always excluded, as Guile doesn't have a nice way to prevent set!
+;; on imported bindings. But variable-set! is included, as no set of
+;; bindings from this module includes a variable or a capability to a
+;; variable. It's possible though to build sandbox modules with no
+;; mutating primitives. As far as we know, all possible combinations of
+;; the binding sets listed below are safe.
+;;
+(define core-bindings
+ '(((guile)
+ and
+ begin
+ apply
+ call-with-values
+ values
+ case
+ case-lambda
+ case-lambda*
+ cond
+ define
+ define*
+ define-values
+ do
+ if
+ lambda
+ lambda*
+ let
+ let*
+ letrec
+ letrec*
+ or
+ quasiquote
+ quote
+ ;; Can't allow mutation to globals.
+ ;; set!
+ unless
+ unquote
+ unquote-splicing
+ when
+ while
+ λ)))
+
+(define macro-bindings
+ '(((guile)
+ bound-identifier=?
+ ;; Although these have "current" in their name, they are lexically
+ ;; scoped, not dynamically scoped.
+ current-filename
+ current-source-location
+ datum->syntax
+ define-macro
+ define-syntax
+ define-syntax-parameter
+ define-syntax-rule
+ defmacro
+ free-identifier=?
+ generate-temporaries
+ gensym
+ identifier-syntax
+ identifier?
+ let-syntax
+ letrec-syntax
+ macroexpand
+ macroexpanded?
+ quasisyntax
+ start-stack
+ syntax
+ syntax->datum
+ syntax-case
+ syntax-error
+ syntax-parameterize
+ syntax-rules
+ syntax-source
+ syntax-violation
+ unsyntax
+ unsyntax-splicing
+ with-ellipsis
+ with-syntax
+ make-variable-transformer)))
+
+(define iteration-bindings
+ '(((guile)
+ compose
+ for-each
+ identity
+ iota
+ map
+ map-in-order
+ const
+ noop)))
+
+(define clock-bindings
+ '(((guile)
+ get-internal-real-time
+ internal-time-units-per-second
+ sleep
+ usleep)))
+
+(define procedure-bindings
+ '(((guile)
+ procedure-documentation
+ procedure-minimum-arity
+ procedure-name
+ procedure?
+ thunk?)))
+
+(define version-bindings
+ '(((guile)
+ effective-version
+ major-version
+ micro-version
+ minor-version
+ version
+ version-matches?)))
+
+(define nil-bindings
+ '(((guile)
+ nil?)))
+
+(define unspecified-bindings
+ '(((guile)
+ unspecified?
+ *unspecified*)))
+
+(define predicate-bindings
+ '(((guile)
+ ->bool
+ and-map
+ and=>
+ boolean?
+ eq?
+ equal?
+ eqv?
+ negate
+ not
+ or-map)))
+
+;; The current ports (current-input-port et al) are dynamically scoped,
+;; which is a footgun from a sandboxing perspective. It's too easy for
+;; a procedure that is the result of a sandboxed evaluation to be later
+;; invoked in a different context and thereby be implicitly granted
+;; capabilities to whatever port is then current. This is compounded by
+;; the fact that most Scheme i/o primitives allow the port to be omitted
+;; and thereby default to whatever's current. For now, sadly, we avoid
+;; exposing any i/o primitive to the sandbox.
+#;
+(define i/o-bindings
+ '(((guile)
+ display
+ eof-object?
+ force-output
+ format
+ make-soft-port
+ newline
+ read
+ simple-format
+ write
+ write-char)
+ ((ice-9 ports)
+ %make-void-port
+ char-ready?
+ ;; Note that these are mutable parameters.
+ current-error-port
+ current-input-port
+ current-output-port
+ current-warning-port
+ drain-input
+ eof-object?
+ file-position
+ force-output
+ ftell
+ input-port?
+ output-port?
+ peek-char
+ port-closed?
+ port-column
+ port-conversion-strategy
+ port-encoding
+ port-filename
+ port-line
+ port-mode
+ port?
+ read-char
+ the-eof-object
+ ;; We don't provide open-output-string because it needs
+ ;; get-output-string, and get-output-string provides a generic
+ ;; capability on any output string port. For consistency then we
+ ;; don't provide open-input-string either; call-with-input-string
+ ;; is sufficient.
+ call-with-input-string
+ call-with-output-string
+ with-error-to-port
+ with-error-to-string
+ with-input-from-port
+ with-input-from-string
+ with-output-to-port
+ with-output-to-string)))
+
+;; If two evaluations are called with the same input port, unread-char
+;; and unread-string can use a port as a mutable channel to pass
+;; information from one to the other.
+#;
+(define mutating-i/o-bindings
+ '(((guile)
+ set-port-encoding!)
+ ((ice-9 ports)
+ close-input-port
+ close-output-port
+ close-port
+ file-set-position
+ seek
+ set-port-column!
+ set-port-conversion-strategy!
+ set-port-encoding!
+ set-port-filename!
+ set-port-line!
+ setvbuf
+ unread-char
+ unread-string)))
+
+(define error-bindings
+ '(((guile)
+ error
+ throw
+ with-throw-handler
+ catch
+ ;; false-if-exception can cause i/o if the #:warning arg is passed.
+ ;; false-if-exception
+
+ ;; See notes on i/o-bindings.
+ ;; peek
+ ;; pk
+ ;; print-exception
+ ;; warn
+ strerror
+ scm-error
+ )))
+
+;; FIXME: Currently we can't expose anything that works on the current
+;; module to the sandbox. It could be that the sandboxed evaluation
+;; returns a procedure, and that procedure may later be invoked in a
+;; different context with a different current-module and it is unlikely
+;; that the later caller will consider themselves as granting a
+;; capability on whatever module is then current. Likewise export (and
+;; by extension, define-public and the like) also operate on the current
+;; module.
+;;
+;; It could be that we could expose a statically scoped eval to the
+;; sandbox.
+#;
+(define eval-bindings
+ '(((guile)
+ current-module
+ module-name
+ module?
+ define-once
+ define-private
+ define-public
+ defined?
+ export
+ defmacro-public
+ ;; FIXME: single-arg eval?
+ eval
+ primitive-eval
+ eval-string
+ self-evaluating?
+ ;; Can we?
+ set-current-module)))
+
+(define sort-bindings
+ '(((guile)
+ sort
+ sorted?
+ stable-sort
+ sort-list)))
+
+;; These can only form part of a safe binding set if no mutable pair or
+;; vector is exposed to the sandbox.
+(define mutating-sort-bindings
+ '(((guile)
+ sort!
+ stable-sort!
+ sort-list!
+ restricted-vector-sort!)))
+
+(define regexp-bindings
+ '(((guile)
+ make-regexp
+ regexp-exec
+ regexp/basic
+ regexp/extended
+ regexp/icase
+ regexp/newline
+ regexp/notbol
+ regexp/noteol
+ regexp?)))
+
+(define alist-bindings
+ '(((guile)
+ acons
+ assoc
+ assoc-ref
+ assq
+ assq-ref
+ assv
+ assv-ref
+ sloppy-assoc
+ sloppy-assq
+ sloppy-assv)))
+
+;; These can only form part of a safe binding set if no mutable pair
+;; is exposed to the sandbox. Unfortunately all charsets in Guile are
+;; mutable, currently, including the built-in charsets, so we can't
+;; expose these primitives.
+(define mutating-alist-bindings
+ '(((guile)
+ assoc-remove!
+ assoc-set!
+ assq-remove!
+ assq-set!
+ assv-remove!
+ assv-set!)))
+
+(define number-bindings
+ '(((guile)
+ *
+ +
+ -
+ /
+ 1+
+ 1-
+ <
+ <=
+ =
+ >
+ >=
+ abs
+ acos
+ acosh
+ angle
+ asin
+ asinh
+ atan
+ atanh
+ ceiling
+ ceiling-quotient
+ ceiling-remainder
+ ceiling/
+ centered-quotient
+ centered-remainder
+ centered/
+ complex?
+ cos
+ cosh
+ denominator
+ euclidean-quotient
+ euclidean-remainder
+ euclidean/
+ even?
+ exact->inexact
+ exact-integer-sqrt
+ exact-integer?
+ exact?
+ exp
+ expt
+ finite?
+ floor
+ floor-quotient
+ floor-remainder
+ floor/
+ gcd
+ imag-part
+ inf
+ inf?
+ integer-expt
+ integer-length
+ integer?
+ lcm
+ log
+ log10
+ magnitude
+ make-polar
+ make-rectangular
+ max
+ min
+ modulo
+ modulo-expt
+ most-negative-fixnum
+ most-positive-fixnum
+ nan
+ nan?
+ negative?
+ numerator
+ odd?
+ positive?
+ quotient
+ rational?
+ rationalize
+ real-part
+ real?
+ remainder
+ round
+ round-quotient
+ round-remainder
+ round/
+ sin
+ sinh
+ sqrt
+ tan
+ tanh
+ truncate
+ truncate-quotient
+ truncate-remainder
+ truncate/
+ zero?
+ number?
+ number->string
+ string->number)))
+
+(define char-set-bindings
+ '(((guile)
+ ->char-set
+ char-set
+ char-set->list
+ char-set->string
+ char-set-adjoin
+ char-set-any
+ char-set-complement
+ char-set-contains?
+ char-set-copy
+ char-set-count
+ char-set-cursor
+ char-set-cursor-next
+ char-set-delete
+ char-set-diff+intersection
+ char-set-difference
+ char-set-every
+ char-set-filter
+ char-set-fold
+ char-set-for-each
+ char-set-hash
+ char-set-intersection
+ char-set-map
+ char-set-ref
+ char-set-size
+ char-set-unfold
+ char-set-union
+ char-set-xor
+ char-set:ascii
+ char-set:blank
+ char-set:designated
+ char-set:digit
+ char-set:empty
+ char-set:full
+ char-set:graphic
+ char-set:hex-digit
+ char-set:iso-control
+ char-set:letter
+ char-set:letter+digit
+ char-set:lower-case
+ char-set:printing
+ char-set:punctuation
+ char-set:symbol
+ char-set:title-case
+ char-set:upper-case
+ char-set:whitespace
+ char-set<=
+ char-set=
+ char-set?
+ end-of-char-set?
+ list->char-set
+ string->char-set
+ ucs-range->char-set)))
+
+;; These can only form part of a safe binding set if no mutable char-set
+;; is exposed to the sandbox. Unfortunately all charsets in Guile are
+;; mutable, currently, including the built-in charsets, so we can't
+;; expose these primitives.
+#;
+(define mutating-char-set-bindings
+ '(((guile)
+ char-set-adjoin!
+ char-set-complement!
+ char-set-delete!
+ char-set-diff+intersection!
+ char-set-difference!
+ char-set-filter!
+ char-set-intersection!
+ char-set-unfold!
+ char-set-union!
+ char-set-xor!
+ list->char-set!
+ string->char-set!
+ ucs-range->char-set!)))
+
+(define array-bindings
+ '(((guile)
+ array->list
+ array-cell-ref
+ array-contents
+ array-dimensions
+ array-equal?
+ array-for-each
+ array-in-bounds?
+ array-length
+ array-rank
+ array-ref
+ array-shape
+ array-slice
+ array-slice-for-each
+ array-slice-for-each-in-order
+ array-type
+ array-type-code
+ array?
+ list->array
+ list->typed-array
+ make-array
+ make-shared-array
+ make-typed-array
+ shared-array-increments
+ shared-array-offset
+ shared-array-root
+ transpose-array
+ typed-array?)))
+
+;; These can only form part of a safe binding set if no mutable vector,
+;; bitvector, bytevector, srfi-4 vector, or array is exposed to the
+;; sandbox.
+(define mutating-array-bindings
+ '(((guile)
+ array-cell-set!
+ array-copy!
+ array-copy-in-order!
+ array-fill!
+ array-index-map!
+ array-map!
+ array-map-in-order!
+ array-set!)))
+
+(define hash-bindings
+ '(((guile)
+ doubly-weak-hash-table?
+ hash
+ hash-count
+ hash-fold
+ hash-for-each
+ hash-for-each-handle
+ hash-get-handle
+ hash-map->list
+ hash-ref
+ hash-table?
+ hashq
+ hashq-get-handle
+ hashq-ref
+ hashv
+ hashv-get-handle
+ hashv-ref
+ hashx-get-handle
+ hashx-ref
+ make-doubly-weak-hash-table
+ make-hash-table
+ make-weak-key-hash-table
+ make-weak-value-hash-table
+ weak-key-hash-table?
+ weak-value-hash-table?)))
+
+;; These can only form part of a safe binding set if no hash table is
+;; exposed to the sandbox.
+(define mutating-hash-bindings
+ '(((guile)
+ hash-clear!
+ hash-create-handle!
+ hash-remove!
+ hash-set!
+ hashq-create-handle!
+ hashq-remove!
+ hashq-set!
+ hashv-create-handle!
+ hashv-remove!
+ hashv-set!
+ hashx-create-handle!
+ hashx-remove!
+ hashx-set!)))
+
+(define variable-bindings
+ '(((guile)
+ make-undefined-variable
+ make-variable
+ variable-bound?
+ variable-ref
+ variable?)))
+
+;; These can only form part of a safe binding set if no mutable variable
+;; is exposed to the sandbox; this applies particularly to variables
+;; that are module bindings.
+(define mutating-variable-bindings
+ '(((guile)
+ variable-set!
+ variable-unset!)))
+
+(define string-bindings
+ '(((guile)
+ absolute-file-name?
+ file-name-separator-string
+ file-name-separator?
+ in-vicinity
+ basename
+ dirname
+
+ list->string
+ make-string
+ object->string
+ reverse-list->string
+ string
+ string->list
+ string-any
+ string-any-c-code
+ string-append
+ string-append/shared
+ string-capitalize
+ string-ci<
+ string-ci<=
+ string-ci<=?
+ string-ci<>
+ string-ci<?
+ string-ci=
+ string-ci=?
+ string-ci>
+ string-ci>=
+ string-ci>=?
+ string-ci>?
+ string-compare
+ string-compare-ci
+ string-concatenate
+ string-concatenate-reverse
+ string-concatenate-reverse/shared
+ string-concatenate/shared
+ string-contains
+ string-contains-ci
+ string-copy
+ string-count
+ string-delete
+ string-downcase
+ string-drop
+ string-drop-right
+ string-every
+ string-every-c-code
+ string-filter
+ string-fold
+ string-fold-right
+ string-for-each
+ string-for-each-index
+ string-hash
+ string-hash-ci
+ string-index
+ string-index-right
+ string-join
+ string-length
+ string-map
+ string-normalize-nfc
+ string-normalize-nfd
+ string-normalize-nfkc
+ string-normalize-nfkd
+ string-null?
+ string-pad
+ string-pad-right
+ string-prefix-ci?
+ string-prefix-length
+ string-prefix-length-ci
+ string-prefix?
+ string-ref
+ string-replace
+ string-reverse
+ string-rindex
+ string-skip
+ string-skip-right
+ string-split
+ string-suffix-ci?
+ string-suffix-length
+ string-suffix-length-ci
+ string-suffix?
+ string-tabulate
+ string-take
+ string-take-right
+ string-titlecase
+ string-tokenize
+ string-trim
+ string-trim-both
+ string-trim-right
+ string-unfold
+ string-unfold-right
+ string-upcase
+ string-utf8-length
+ string<
+ string<=
+ string<=?
+ string<>
+ string<?
+ string=
+ string=?
+ string>
+ string>=
+ string>=?
+ string>?
+ string?
+ substring
+ substring/copy
+ substring/read-only
+ substring/shared
+ xsubstring)))
+
+;; These can only form part of a safe binding set if no mutable string
+;; is exposed to the sandbox.
+(define mutating-string-bindings
+ '(((guile)
+ string-capitalize!
+ string-copy!
+ string-downcase!
+ string-fill!
+ string-map!
+ string-reverse!
+ string-set!
+ string-titlecase!
+ string-upcase!
+ string-xcopy!
+ substring-fill!
+ substring-move!)))
+
+(define symbol-bindings
+ '(((guile)
+ string->symbol
+ string-ci->symbol
+ symbol->string
+ list->symbol
+ make-symbol
+ symbol
+ symbol-append
+ symbol-hash
+ symbol-interned?
+ symbol?)))
+
+(define keyword-bindings
+ '(((guile)
+ keyword?
+ keyword->symbol
+ symbol->keyword)))
+
+;; These can only form part of a safe binding set if no valid prompt tag
+;; is ever exposed to the sandbox, or can be constructed by the sandbox.
+(define prompt-bindings
+ '(((guile)
+ abort-to-prompt
+ abort-to-prompt*
+ call-with-prompt
+ make-prompt-tag)))
+
+(define bit-bindings
+ '(((guile)
+ ash
+ round-ash
+ logand
+ logcount
+ logior
+ lognot
+ logtest
+ logxor
+ logbit?)))
+
+(define bitvector-bindings
+ '(((guile)
+ bit-count
+ bit-count*
+ bit-extract
+ bit-position
+ bitvector
+ bitvector->list
+ bitvector-length
+ bitvector-ref
+ bitvector?
+ list->bitvector
+ make-bitvector)))
+
+;; These can only form part of a safe binding set if no mutable
+;; bitvector is exposed to the sandbox.
+(define mutating-bitvector-bindings
+ '(((guile)
+ bit-invert!
+ bit-set*!
+ bitvector-fill!
+ bitvector-set!)))
+
+(define fluid-bindings
+ '(((guile)
+ fluid-bound?
+ fluid-ref
+ ;; fluid-ref* could escape the sandbox and is not allowed.
+ fluid-thread-local?
+ fluid?
+ make-fluid
+ make-thread-local-fluid
+ make-unbound-fluid
+ with-fluid*
+ with-fluids
+ with-fluids*
+ make-parameter
+ parameter?
+ parameterize)))
+
+;; These can only form part of a safe binding set if no fluid is
+;; directly exposed to the sandbox.
+(define mutating-fluid-bindings
+ '(((guile)
+ fluid-set!
+ fluid-unset!
+ fluid->parameter)))
+
+(define char-bindings
+ '(((guile)
+ char-alphabetic?
+ char-ci<=?
+ char-ci<?
+ char-ci=?
+ char-ci>=?
+ char-ci>?
+ char-downcase
+ char-general-category
+ char-is-both?
+ char-lower-case?
+ char-numeric?
+ char-titlecase
+ char-upcase
+ char-upper-case?
+ char-whitespace?
+ char<=?
+ char<?
+ char=?
+ char>=?
+ char>?
+ char?
+ char->integer
+ integer->char)))
+
+(define list-bindings
+ '(((guile)
+ list
+ list-cdr-ref
+ list-copy
+ list-head
+ list-index
+ list-ref
+ list-tail
+ list?
+ null?
+ make-list
+ append
+ delete
+ delq
+ delv
+ filter
+ length
+ member
+ memq
+ memv
+ merge
+ reverse)))
+
+;; These can only form part of a safe binding set if no mutable
+;; pair is exposed to the sandbox.
+(define mutating-list-bindings
+ '(((guile)
+ list-cdr-set!
+ list-set!
+ append!
+ delete!
+ delete1!
+ delq!
+ delq1!
+ delv!
+ delv1!
+ filter!
+ merge!
+ reverse!)))
+
+(define pair-bindings
+ '(((guile)
+ last-pair
+ pair?
+ caaaar
+ caaadr
+ caaar
+ caadar
+ caaddr
+ caadr
+ caar
+ cadaar
+ cadadr
+ cadar
+ caddar
+ cadddr
+ caddr
+ cadr
+ car
+ cdaaar
+ cdaadr
+ cdaar
+ cdadar
+ cdaddr
+ cdadr
+ cdar
+ cddaar
+ cddadr
+ cddar
+ cdddar
+ cddddr
+ cdddr
+ cddr
+ cdr
+ cons
+ cons*)))
+
+;; These can only form part of a safe binding set if no mutable
+;; pair is exposed to the sandbox.
+(define mutating-pair-bindings
+ '(((guile)
+ set-car!
+ set-cdr!)))
+
+(define vector-bindings
+ '(((guile)
+ list->vector
+ make-vector
+ vector
+ vector->list
+ vector-copy
+ vector-length
+ vector-ref
+ vector?)))
+
+;; These can only form part of a safe binding set if no mutable
+;; vector is exposed to the sandbox.
+(define mutating-vector-bindings
+ '(((guile)
+ vector-fill!
+ vector-move-left!
+ vector-move-right!
+ vector-set!)))
+
+(define promise-bindings
+ '(((guile)
+ force
+ delay
+ make-promise
+ promise?)))
+
+(define srfi-4-bindings
+ '(((srfi srfi-4)
+ f32vector
+ f32vector->list
+ f32vector-length
+ f32vector-ref
+ f32vector?
+ f64vector
+ f64vector->list
+ f64vector-length
+ f64vector-ref
+ f64vector?
+ list->f32vector
+ list->f64vector
+ list->s16vector
+ list->s32vector
+ list->s64vector
+ list->s8vector
+ list->u16vector
+ list->u32vector
+ list->u64vector
+ list->u8vector
+ make-f32vector
+ make-f64vector
+ make-s16vector
+ make-s32vector
+ make-s64vector
+ make-s8vector
+ make-u16vector
+ make-u32vector
+ make-u64vector
+ make-u8vector
+ s16vector
+ s16vector->list
+ s16vector-length
+ s16vector-ref
+ s16vector?
+ s32vector
+ s32vector->list
+ s32vector-length
+ s32vector-ref
+ s32vector?
+ s64vector
+ s64vector->list
+ s64vector-length
+ s64vector-ref
+ s64vector?
+ s8vector
+ s8vector->list
+ s8vector-length
+ s8vector-ref
+ s8vector?
+ u16vector
+ u16vector->list
+ u16vector-length
+ u16vector-ref
+ u16vector?
+ u32vector
+ u32vector->list
+ u32vector-length
+ u32vector-ref
+ u32vector?
+ u64vector
+ u64vector->list
+ u64vector-length
+ u64vector-ref
+ u64vector?
+ u8vector
+ u8vector->list
+ u8vector-length
+ u8vector-ref
+ u8vector?)))
+
+;; These can only form part of a safe binding set if no mutable
+;; bytevector is exposed to the sandbox.
+(define mutating-srfi-4-bindings
+ '(((srfi srfi-4)
+ f32vector-set!
+ f64vector-set!
+ s16vector-set!
+ s32vector-set!
+ s64vector-set!
+ s8vector-set!
+ u16vector-set!
+ u32vector-set!
+ u64vector-set!
+ u8vector-set!)))
+
+(define all-pure-bindings
+ (append alist-bindings
+ array-bindings
+ bit-bindings
+ bitvector-bindings
+ char-bindings
+ char-set-bindings
+ clock-bindings
+ core-bindings
+ error-bindings
+ fluid-bindings
+ hash-bindings
+ iteration-bindings
+ keyword-bindings
+ list-bindings
+ macro-bindings
+ nil-bindings
+ number-bindings
+ pair-bindings
+ predicate-bindings
+ procedure-bindings
+ promise-bindings
+ prompt-bindings
+ regexp-bindings
+ sort-bindings
+ srfi-4-bindings
+ string-bindings
+ symbol-bindings
+ unspecified-bindings
+ variable-bindings
+ vector-bindings
+ version-bindings))
+
+
+(define all-pure-and-impure-bindings
+ (append all-pure-bindings
+ mutating-alist-bindings
+ mutating-array-bindings
+ mutating-bitvector-bindings
+ mutating-fluid-bindings
+ mutating-hash-bindings
+ mutating-list-bindings
+ mutating-pair-bindings
+ mutating-sort-bindings
+ mutating-srfi-4-bindings
+ mutating-string-bindings
+ mutating-variable-bindings
+ mutating-vector-bindings))