safe script evaluator

[Ulf Wiger (AL/EAB)]

I'm playing around with writing a (supposedly) safe script evaluator
using erl_eval.

The current state of the code is shown below (it's work in progress -
don't expect it to be complete.)

I kindof got stuck on the following description of the non-local
function handler, which can be used with erl_eval:exprs/4:

"The nonlocal function handler argument is probably not used as
frequently as the local function handler argument. A possible use is to
call exit/1 on calls to functions that for some reason are not allowed
to be called."

This is all fine, and exactly what I want - BUT, it seems the non-local
function handler is NOT called for calls to apply/3. This means that I
can't really use the non-local function handler for disallowing any
calls, unless I traverse the expressions and rewrite them.

This is what I do in the code below. I also search for message sending
and receive expressions, which are also disallowed.

If anyone can think of anything else that needs to be trapped in the
code below, please hollar.

BR,
Ulf W


%%% =========================== Begin script evaluator

op_eval(W, Script) ->
    fun() ->
	    case erl_scan:string(Script, 1) of
		{ok, Tokens, _} ->
		    case erl_parse:parse_exprs(Tokens) of
			{ok, Exprs} ->
			    io:format("Exprs = ~p~n", [Exprs]),
			    Exprs1 = rewrite_expr(Exprs),
			    case erl_eval:exprs(Exprs1, [],
						{value, fun
local_fun/2},
						{value, fun
remote_fun/2}) of
				{value, Value, NewBs} ->
				    {true, {Value, NewBs}}
			    end;
			Error ->
			    {false, Error}
		    end;
		ScanError ->
		    {false, ScanError}
	    end
    end.

rewrite_expr(E) ->
    [erl_syntax:revert(T) || T <- lists:flatten(rewrite_expr1(E))].

rewrite_expr1(Es) when is_list(Es) ->
    [rewrite_expr1(E) || E <- Es];
rewrite_expr1(E) ->
    E1 =
	case erl_syntax:type(E) of
	    application ->
		case erl_syntax_lib:analyze_application(E) of
		    {apply, 3} ->
			safe_apply_expr(E);
		    {erlang,apply,3} ->
			safe_apply_expr(E);
		    _ ->
			E
		end;
	    receive_expr ->
		erlang:error({invalid_expr, 'receive'});
	    infix_expr ->
		Op = erl_syntax:operator_name(
		       erl_syntax:infix_expr_operator(E)),
		case valid_infix_operator(Op) of
		    true ->
			E;
		    false ->
			erlang:error({invalid_operator, Op})
		end;
	    _ ->
		E
	end,
    case erl_syntax:subtrees(E1) of
	[] ->
	    E1;
	SubTrees ->
	    erl_syntax:update_tree(E1, [rewrite_expr1(T) || T <-
SubTrees])
    end.

valid_infix_operator('!') -> false;
valid_infix_operator(_) -> true.
     

safe_apply_expr(E) ->
    Args = erl_syntax:application_arguments(E),
    erl_syntax:application(
      erl_syntax:atom(safe_apply),
      Args).
	    
local_fun(safe_apply, [M, F, Args]) ->
    io:format("safe_apply(~p, ~p, ~p)~n", [M, F, Args]),
    case is_allowed(M, F, length(Args)) of
	true ->
	    apply(M, F, Args);
	false ->
	    erlang:error({undef, [{M, F, Args}]})
    end;
local_fun(Name, Args) ->
    io:format("local_fun(~p, ~p)~n", [Name, Args]),
    true.

remote_fun({M, F}, Args) ->
    Arity = length(Args),
    case is_allowed(M, F, Arity) of
	true ->
	    apply(M, F, Args);
	false ->
	    erlang:error({undef, [{M, F, Arity}]})
    end;
remote_fun(F, Args) ->
    erlang:error({undef, [{F, length(Args)}]}).



is_allowed(erlang, round, 1)                      -> true;
is_allowed(erlang, atom_to_list, 1)               -> true;
is_allowed(erlang, binary_to_list, 1)             -> true;
is_allowed(erlang, list_to_binary, 1)             -> true;
is_allowed(erlang, integer_to_list, 1)            -> true;
is_allowed(erlang, list_to_integer, 1)            -> true;
is_allowed(erlang, setelement, 3)                 -> true;
is_allowed(erlang, element, 2)                    -> true;
is_allowed(erlang, size, 1)                       -> true;
is_allowed(erlang, split_binary, 2)               -> true;
is_allowed(erlang, term_to_binary, 1)             -> true;
is_allowed(erlang, term_to_binary, 2)             -> true;
is_allowed(erlang, binary_to_term, 1)             -> true;
is_allowed(erlang, throw, 1)                      -> true;
is_allowed(erlang, time, 0)                       -> true;
is_allowed(erlang, now, 0)                        -> true;
is_allowed(erlang, universal_time, 0)             -> true;
is_allowed(erlang, localtime, 0)                  -> true;
is_allowed(erlang, localtime_to_universaltime, 1) -> true;
is_allowed(erlang, localtime_to_universaltime, 2) -> true;
is_allowed(erlang, make_ref, 0) -> true;
%%
is_allowed(lists, _, _)    -> true;
is_allowed(sets, _, _)     -> true;
is_allowed(ordsets, _, _)  -> true;
is_allowed(dict, _, _)     -> true;
is_allowed(orddict, _, _)  -> true;
is_allowed(gb_trees, _, _) -> true;
is_allowed(calendar, _, _) -> true;
is_allowed(_, _, _) ->
    false.
     

%%% =========================== End script evaluator