Basic sandboxing

diff --git a/extra/sandbox/authors.txt b/extra/sandbox/authors.txt
new file mode 100644 (file)
index 0000000..f97e1bf
--- /dev/null
+++ b/extra/sandbox/authors.txt
@@ -0,0 +1 @@
+Maxim Savchenko

diff --git a/extra/sandbox/sandbox-tests.factor b/extra/sandbox/sandbox-tests.factor
new file mode 100644 (file)
index 0000000..5d0496e
--- /dev/null
+++ b/extra/sandbox/sandbox-tests.factor
@@ -0,0 +1,57 @@
+! Copyright (C) 2009 Maxim Savchenko
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel accessors continuations lexer vocabs vocabs.parser
+       combinators.short-circuit sandbox tools.test ;
+
+IN: sandbox.tests
+
+<< "sandbox.syntax" load-vocab drop >>
+USE: sandbox.syntax.private
+
+: run-script ( x lines -- y )
+    H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } }
+    parse-sandbox call( x -- x! ) ;
+
+[ 120 ]
+[
+    5
+    {
+        "! Simple factorial example"
+        "APPLYING: kernel math sequences ;"
+        "1 swap [ 1+ * ] each"
+    } run-script
+] unit-test
+
+[
+    5
+    {
+        "! Jailbreak attempt with USE:"
+        "USE: io"
+        "\"Hello world!\" print"
+    } run-script
+]
+[
+    {
+        [ lexer-error? ]
+        [ error>> condition? ]
+        [ error>> error>> no-word-error? ]
+        [ error>> error>> name>> "USE:" = ]
+    } 1&&
+] must-fail-with
+
+[
+    5
+    {
+        "! Jailbreak attempt with unauthorized APPLY:"
+        "APPLY: io"
+        "\"Hello world!\" print"
+    } run-script
+]
+[
+    {
+        [ lexer-error? ]
+        [ error>> sandbox-error? ]
+        [ error>> vocab>> "io" = ]
+    } 1&&
+] must-fail-with

diff --git a/extra/sandbox/sandbox.factor b/extra/sandbox/sandbox.factor
new file mode 100644 (file)
index 0000000..a9d65ee
--- /dev/null
+++ b/extra/sandbox/sandbox.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences vectors assocs namespaces parser lexer vocabs
+       combinators.short-circuit vocabs.parser ;
+
+IN: sandbox
+
+SYMBOL: whitelist
+
+: with-sandbox-vocabs ( quot -- )
+    "sandbox.syntax" load-vocab vocab-words 1vector
+    use [ call ] with-variable ; inline
+
+: parse-sandbox ( lines assoc -- quot )
+    whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ;
+
+: reveal-in ( name -- )
+    [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ;
+
+SYNTAX: REVEAL: scan reveal-in ;
+
+SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ;

diff --git a/extra/sandbox/summary.txt b/extra/sandbox/summary.txt
new file mode 100644 (file)
index 0000000..3ca1e25
--- /dev/null
+++ b/extra/sandbox/summary.txt
@@ -0,0 +1 @@
+Basic sandboxing

diff --git a/extra/sandbox/syntax/syntax.factor b/extra/sandbox/syntax/syntax.factor
new file mode 100644 (file)
index 0000000..2ff5f07
--- /dev/null
+++ b/extra/sandbox/syntax/syntax.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ;
+IN: sandbox.syntax
+
+<PRIVATE
+
+ERROR: sandbox-error vocab ;
+
+: sandbox-use+ ( alias -- )
+    dup whitelist get at [ use+ ] [ sandbox-error ] ?if ;
+
+PRIVATE>
+
+SYNTAX: APPLY: scan sandbox-use+ ;
+
+SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
+
+REVEALING:
+    ! #!
+    HEX: OCT: BIN: f t CHAR: "
+    [ { T{
+    ] } ;
+
+REVEAL: ;