evaling'

sandbox.el

@@ -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,34 +27,32 @@
 ;; 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
 
 
 
 (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."
   )
 
-
-
 ;; main entry point is sandbox
 ;; sandbox takes an expression and makes sure it is okay to evaluate
 
@@ -76,17 +74,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,39 +98,127 @@ 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?"  ))
        (t expr)))
    ))
 
 
+;; 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)
+    (let ((is-interactive-form (equal '(interactive) (first body))))
+      (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
+                           `(sandbox--check-args ,@args)
+                           (cons
+                            '(sit-for 0)
+                            body)))))))))
+
+(defun sandbox-eval (form &optional prefix)
+  (unless (or (stringp prefix) (eq nil prefix))
+    (error "Prefix should be a string"))
+  (let ((sandbox-prefix (or prefix sandbox-prefix))
+        (sandbox-defun-symbol (intern (concat sandbox-prefix "defun")))
+        (sandbox-while-symbol (intern (concat sandbox-prefix "while"))))
+    (flet ((sandbox-defun-symbol (fcn args &rest body ) (sandbox-defun fcn args body))
+           (sandbox-while-symbol (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

spec/sandbox-spec.el

@@ -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,43 +43,71 @@
     (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 functions in the sandboxed namespace"
+    (progn
+      (sandbox-defun testfn (one two) (+ one two))
+      (should (eq 3 (emacs-sandbox-testfn 1 2)))))
+  (it "handles functions with docstrings too"
+    (progn
+      (sandbox-defun testfn (one two) "test function" (+ one two))
+      (should (eq 3 (emacs-sandbox-testfn 1 2))))))
+
+
+(describe "sandbox-while"
+  (it "wont allow infinite looping"
+    (should-error
+     (let ((i 0))
+       (sandbox-while t (incf i))))))
+
+(describe "sandbox-eval"
+  (it "will eval defuns in a different namespace"
+    ;; todo: make a test scenario that will actually pass
+    (should (eq 3
+                (sandbox-eval
+                 '(progn (defun testfn (one two) (+ one two))
+                         (testfn 1 2)))))))
 
 ;; 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))))))
 
 
 (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))
+    :type 'void-function)
+
+  (it "wont loop forever with sandbox-eval"
+    (should-error
+     (sandbox-eval (sandbox '(while t (setq what-doing "looping")))))))
+
+
 
 (defun emacs-sandbox-message (val))
 
 
 (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 +116,5 @@
 
 ;;;;;;;;;;;;;;;;
 ;; need two types of specs to advance:
-;; the first is examples of 
+;; the first is examples of
 ;;