Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

added sandbox-defun and sandbox-while from erbot

  • Loading branch information...
commit 57b07e86986abd3379e61c994f6f2ea59adff8f3 1 parent 1ceb9cd
dcluna authored
Showing with 121 additions and 31 deletions.
  1. +100 −16 sandbox.el
  2. +21 −15 spec/sandbox-spec.el
116 sandbox.el
View
@@ -12,12 +12,12 @@
;; Package: erblisp
;; This file is NOT (yet) part of GNU Emacs.
-
+
;; This is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
-
+
;; This 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
@@ -27,14 +27,14 @@
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
-
+
;; this file is adapted from the code from erbot. see:
;; http://www.emacswiki.org/cgi-bin/wiki.pl?ErBot
-;; eventually I hope to make it better, but for now
+;; eventually I hope to make it better, but for now
;; other projects can use the same sandboxing functionality
@@ -42,14 +42,14 @@
(defvar sandbox-prefix "emacs-sandbox-")
(defvar sandbox-allowed-words
'(nil
- t
+ t
;; Also consider:
&rest
&optional
)
- "You should add &rest and &optional to this list.
+ "You should add &rest and &optional to this list.
We WON'T do this by default since this could lead to exploits if you
-*happen* to have bound these keywords to weird stuff like
+*happen* to have bound these keywords to weird stuff like
\(setq &rest (shell-command \"rm -rf /\")) in your .emacs."
)
@@ -76,17 +76,18 @@ We WON'T do this by default since this could lead to exploits if you
((equal (format "%S" fir) "quote")
;; if quoted, it is fine...
expr)
- (t (cons
+ (t (cons
(if (or (equal 0 (string-match sandbox-prefix (format "%S" fir)))
(member fir sandbox-allowed-words))
fir
+ ;; todo: bind this to its original name
(intern (concat sandbox-prefix (format "%S" fir))))
(mapcar 'sandbox (cdr expr))))))))
;; final condition.. --> when the expr is an atom.. It should be a
;; a constant.. or an allowed atom.. allowed == prefixed with fs-
(t (cond
- ((and (symbolp expr)
+ ((and (symbolp expr)
(equal 0 (string-match sandbox-prefix (format "%s" expr))))
expr)
((equal expr t) expr)
@@ -99,7 +100,7 @@ We WON'T do this by default since this could lead to exploits if you
;; a number or string now..
;; this actually happens when they feed byte-compiled code to
;; the bot, like:
- ;;, (funcall #[nil "\300\207" [1] 1])
+ ;;, (funcall #[nil "\300\207" [1] 1])
((not (or (symbolp expr) (numberp expr) (stringp expr)))
(error "%s %s" "Should not reach here. Quantum Tunnelling! "
"What are you trying to feed me? Byte-compiled code? Vectors?" ))
@@ -107,31 +108,114 @@ We WON'T do this by default since this could lead to exploits if you
))
+;; integrating erbot's sandbox functions
+
+(defvar sandbox-while-ctr 0)
+(defvar sandbox-while-max 10000)
+
+(defmacro sandbox-while (cond &rest body)
+ `(let
+ ((sandbox-while-ctr 0))
+ (while
+ ,cond
+ ;; this should enable the with-timeout checks..
+ ;; (sleep-for 0.01)
+ (if (> sandbox-while-ctr sandbox-while-max)
+ (error "Max while iterations exceeded: %S"
+ sandbox-while-ctr))
+ (incf sandbox-while-ctr)
+ nil
+ ,@body)))
+
+
+(defun sandbox-constant-object-p (object)
+ "If the object is a symbol like nil or t, a symbol that cannot be
+redefunned, return true. "
+ (or (member object (list nil t))
+ (keywordp object)))
+
+(defun sandbox-readonly-check (sym)
+ (if (get sym 'readonly)
+ (error "The symbol %S can't be redefined or set! It is read-only!"
+ sym)))
+
+(defun sandbox-create-defun-overwrite (sexps body fcn)
+ (cons body
+ (remove
+ (first (member-if
+ (lambda (arg) (equal (second arg) fcn))
+ sexps))
+ sexps)))
+
+(defmacro sandbox-defun (fcn args &rest body)
+ ;; the given fcn icould be a number or string, in which
+ ;; case sandboxing won't touch it, so we need to override that case.
+ (let ((docp nil)
+ (sandbox-fcn (cond
+ ((or (numberp fcn) (stringp fcn)) fcn)
+ (t (intern (concat sandbox-prefix (symbol-name fcn)))))))
+ (unless
+ (and (listp body)
+ (> (length body) 0))
+ (error "Function body should have a length of 1 or more"))
+ (unless (and (symbolp sandbox-fcn) (not (sandbox-constant-object-p sandbox-fcn)))
+ (error "Defun symbols only! :P"))
+ ;; doc string exists, and is followed by more stuff..
+ (when (and (> (length body) 1)
+ (stringp (first body)))
+ (setq docp t))
+ (sandbox-readonly-check sandbox-fcn)
+ (if docp
+ (cons 'defun
+ (cons sandbox-fcn
+ (cons args
+ (cons
+ (first body)
+ (cons
+ `(sandbox--check-args ,@args)
+ (cons
+ '(sit-for 0)
+ (cdr body)))))))
+ (cons 'defun
+ (cons sandbox-fcn
+ (cons args
+ (cons
+ (first body)
+ (cons
+ `(sandbox--check-args ,@args)
+ (cons
+ '(sit-for 0)
+ (cdr body))))))))))
+
+(defun sandbox-eval (form)
+ (flet (((intern (concat sandbox-prefix "while")) (cond &rest body) (sandbox-while cond body)))
+ (eval (sandbox form))))
+
(defvar sandbox-max-list-length 100)
(defmacro sandbox--check-args (&rest args)
"All we do in this macro we remove some bindings for things like
&rest, etc, things that do not have values but got passed to us --
this occurs when a user attempts to use &rest in his function
-definitions -- see `sandbox-allowed-words'.
+definitions -- see `sandbox-allowed-words'.
All the arguments to this macro should have been in their evalled form
and hence constants already, so we do not bother protecting against
multiple evaluations here -- evaluating a constant causes no harm.
All we do in this macro we remove some bindings for things like &rest,
etc, things that are not defined, but passed on here in any case."
- `(sandbox--check-args-nascent
- ,@(remove-if
+ `(sandbox--check-args-nascent
+ ,@(remove-if
#'(lambda (arg) (and
- (symbolp arg)
- (not (boundp arg))))
+ (symbolp arg)
+ (not (boundp arg))))
args)))
(defun sandbox--check-args-nascent (&rest args)
- (if (or
+ (if (or
(not (numberp sandbox-max-list-length))
(sandbox--safe-length-args-p args 0 sandbox-max-list-length))
t
36 spec/sandbox-spec.el
View
@@ -3,15 +3,15 @@
(describe "sandbox"
(it "returns nil when passed the empty list"
(should (null (sandbox '()))))
-
+
(it "rewrites any function as a function with a prefix"
(should (equal (sandbox '(hi t))
'(emacs-sandbox-hi t))))
-
+
(it "allows t, nil, &rest, &optional..."
(should (equal (sandbox '(t nil &rest &optional))
'(t nil &rest &optional))))
-
+
(it "passes a quoted form along as quoted"
;; should this be a preference?
(should (equal (sandbox ''(hi t))
@@ -20,10 +20,10 @@
(describe "sandbox--check-args"
(it "is true for an empty list"
(should (equal t (sandbox--check-args nil))))
-
+
(it "is true for a list with a single symbol"
(should (equal t (sandbox--check-args '(wtf)))))
-
+
(it "is true for a list with multiple symbols"
(should (equal t (sandbox--check-args '(wtf omg)))))
@@ -43,22 +43,28 @@
(should (sandbox--safe-length-args-p '((2 3) 2 5 6 7 ) 0 4))
(should-not (sandbox--safe-length-args-p '((2 3) 2) 0 2))))
+(describe "sandbox-defun"
+ (it "makes "))
-
+(describe "sandbox-while"
+ (it "wont allow infinite looping"
+ (should-error
+ (let ((i 0))
+ (sandbox-while t (incf i))))))
;; actual spec tests
(describe "sandbox"
(it "forbids the user from executing the bad stuff"
- (with-mock2
+ (with-mock2
(defmock a-sensitive-function ())
- (should-error
+ (should-error
(eval (sandbox '(a-sensitive-function)))
-
+
:type 'void-function)
(should (= 0 (el-spec:called-count 'a-sensitive-function)))))
-
+
(it "allows the user to execute the good stuff"
- (with-mock2
+ (with-mock2
(defmock emacs-sandbox-not-sensitive ())
(eval (sandbox '(not-sensitive)))
(should (= 1 (el-spec:called-count 'emacs-sandbox-not-sensitive))))))
@@ -66,7 +72,7 @@
(describe "an infinite loop condition"
(it "cant allow looping, i guess"
- (should-error
+ (should-error
(eval (sandbox '(while t
(throw 'omg-should-not-even-be-allowed-to-run!!!)))))
:type 'void-function))
@@ -77,9 +83,9 @@
(describe "user trying to access an outside variable"
(it "doesnt work"
(let ((a-secret 'shhhhh))
- (should-error
+ (should-error
(eval (sandbox '(message a-secret)))
-
+
:type 'void-variable
)
@@ -88,5 +94,5 @@
;;;;;;;;;;;;;;;;
;; need two types of specs to advance:
-;; the first is examples of
+;; the first is examples of
;;

1 comment on commit 57b07e8

Nic Ferrier

One thing, i know whitespace is annoying... but don't fix it. Fixing the whitespace results in what we have above which is very difficult to read; to see what you've changed I have to read a lot of spurious whitespace fix lines.

Please just leave it as is.

Please sign in to comment.
Something went wrong with that request. Please try again.