package App::EvalServer;
BEGIN {
$App::EvalServer::AUTHORITY = 'cpan:HINRIK';
}
BEGIN {
$App::EvalServer::VERSION = '0.08';
}
use strict;
use warnings FATAL => 'all';
# we want instant child process reaping
sub POE::Kernel::USE_SIGCHLD () { return 1 }
use File::Spec::Functions qw<catdir catfile rel2abs>;
use File::Temp qw<tempdir>;
use POE;
use POE::Filter::JSON;
use POE::Filter::Reference;
use POE::Filter::Stream;
use POE::Wheel::SocketFactory;
use POE::Wheel::ReadWrite;
use POE::Wheel::Run;
use POSIX qw<mkfifo>;
use Time::HiRes qw<time>;
my @inc = map { +'-I' => rel2abs($_) } @INC;
my $CHILD_PROGRAM = [
$^X, @inc, '-MApp::EvalServer::Child',
'-e', 'App::EvalServer::Child::run()'
];
my %LANGS = (
perl => 'Perl',
pl => 'Perl',
ruby => 'Ruby',
rb => 'Ruby',
php => 'PHP',
deparse => 'Deparse',
python => 'Python',
py => 'Python',
lua => 'Lua',
j => 'J',
);
sub new {
my ($package, %args) = @_;
my %defaults = (
host => 'localhost',
port => 14400,
user => 'nobody',
timeout => 10,
limit => 50,
);
while (my ($key, $value) = each %defaults) {
$args{$key} = $value if !defined $args{$key};
}
return bless \%args, $package;
}
sub run {
my ($self) = @_;
if ($self->{daemonize}) {
require Proc::Daemon;
eval {
Proc::Daemon::Init->();
$poe_kernel->has_forked();
};
chomp $@;
die "Can't daemonize: $@\n" if $@;
}
POE::Session->create(
object_states => [
$self => [qw(
_start
_shutdown
sig_die
fatal_signal
server_failure
new_client
client_read
client_write
client_error
spawn_eval
eval_stdin
eval_stdout
eval_stderr
eval_result
eval_timeout
eval_sig_child
)],
],
);
return;
}
sub _start {
my ($kernel, $self, $session) = @_[KERNEL, OBJECT, SESSION];
$self->{server} = POE::Wheel::SocketFactory->new(
BindAddress => $self->{host},
BindPort => $self->{port},
SuccessEvent => 'new_client',
FailureEvent => 'server_failure',
Reuse => 'yes',
);
$self->{session_id} = $session->ID;
$kernel->sig(DIE => 'sig_die');
$kernel->sig(INT => 'fatal_signal');
$kernel->sig(TERM => 'fatal_signal');
return;
}
sub sig_die {
my ($kernel, $self, $ex) = @_[KERNEL, OBJECT, ARG1];
chomp $ex->{error_str};
my @errors = (
"Event $ex->{event} in session ".$ex->{dest_session}->ID." raised exception:",
" $ex->{error_str}",
);
warn "$_\n" for @errors;
$kernel->sig_handled();
return;
}
sub fatal_signal {
my ($kernel, $self) = @_[KERNEL, OBJECT];
$kernel->yield('_shutdown');
$kernel->sig_handled();
return;
}
sub server_failure {
my ($self, $operation, $error) = @_[OBJECT, ARG0, ARG2];
delete $self->{server};
warn "$operation failed: $error\n";
return;
}
sub new_client {
my ($self, $handle) = @_[OBJECT, ARG0];
my $wheel = POE::Wheel::ReadWrite->new(
Handle => $handle,
Filter => POE::Filter::JSON->new(),
InputEvent => 'client_read',
FlushedEvent => 'client_write',
ErrorEvent => 'client_error',
);
$self->{clients}{$wheel->ID} = $wheel;
return;
}
sub client_read {
my ($kernel, $self, $input, $wheel_id) = @_[KERNEL, OBJECT, ARG0, ARG1];
my $client = $self->{clients}{$wheel_id};
if (ref $input ne 'HASH') {
$client->put({ error => 'JSON data must be a hash' });
}
elsif (!defined $input->{lang}) {
$client->put({ error => 'No language specified' });
}
elsif (!defined $LANGS{lc $input->{lang}}) {
$client->put({ error => 'Language not supported' });
}
elsif (!defined $input->{code}) {
$client->put({ error => 'Code is missing' });
}
else {
$kernel->yield(
'spawn_eval',
$wheel_id,
$LANGS{lc $input->{lang}},
$input->{code},
$input->{stdin},
);
}
return;
}
sub client_write {
my ($self, $wheel_id) = @_[OBJECT, ARG0];
$self->_remove_client($wheel_id);
return;
}
sub client_error {
my ($self, $wheel_id) = @_[OBJECT, ARG0];
$self->_remove_client($wheel_id);
return;
}
sub _remove_client {
my ($self, $client_id) = @_;
delete $self->{clients}{$client_id};
for my $eval (values %{ $self->{evals} }) {
$eval->{wheel}->kill() if $eval->{client_id} == $client_id;
}
return;
}
sub spawn_eval {
my ($kernel, $self, $client_id, $lang, $code, $stdin)
= @_[KERNEL, OBJECT, ARG0..$#_];
my $tempdir = tempdir(CLEANUP => 1);
my $result_pipe = catfile($tempdir, 'result_pipe');
mkfifo($result_pipe, 0700) or die "mkfifo $result_pipe failed: $!";
my $jail = catdir($tempdir, 'jail');
mkdir $jail or die "Can't mkdir $jail: $!";
my $start_time = time;
my $wheel = POE::Wheel::Run->new(
Program => $CHILD_PROGRAM,
ProgramArgs => [$tempdir, $result_pipe, $jail, $self->{user},
$self->{limit}, $lang, $code, $self->{unsafe}],
Priority => 10,
StdioFilter => POE::Filter::Stream->new(),
StderrFilter => POE::Filter::Stream->new(),
StdinEvent => 'eval_stdin',
StdoutEvent => 'eval_stdout',
StderrEvent => 'eval_stderr',
);
$self->{pid_to_id}{$wheel->PID} = $wheel->ID;
if (defined $stdin) {
$wheel->put($stdin);
}
else {
$wheel->shutdown_stdin();
}
open my $pipe_handle, '<', $result_pipe or die "Can't open $result_pipe: $!";
my $result_wheel = POE::Wheel::ReadWrite->new(
Handle => $pipe_handle,
InputEvent => 'eval_result',
Filter => POE::Filter::Reference->new(),
);
$self->{pipe_to_id}{$result_wheel->ID} = $wheel->ID;
my $alarm_id = $kernel->delay_set('eval_timeout', $self->{timeout}, $wheel->ID);
$self->{evals}{$wheel->ID} = {
wheel => $wheel,
pipe_wheel => $result_wheel,
pipe_name => $result_pipe,
client_id => $client_id,
alarm_id => $alarm_id,
tempdir => $tempdir,
start_time => $start_time,
return => {
stdout => '',
stderr => '',
output => '',
},
};
$kernel->sig_child($wheel->PID, 'eval_sig_child');
return;
}
sub eval_stdout {
my ($self, $chunk, $wheel_id) = @_[OBJECT, ARG0, ARG1];
my $eval = $self->{evals}{$wheel_id};
$eval->{return}{stdout} .= $chunk;
$eval->{return}{output} .= $chunk;
return;
}
sub eval_stderr {
my ($self, $chunk, $wheel_id) = @_[OBJECT, ARG0, ARG1];
my $eval = $self->{evals}{$wheel_id};
$eval->{return}{stderr} .= $chunk;
$eval->{return}{output} .= $chunk;
return;
}
sub eval_result {
my ($self, $return, $id) = @_[OBJECT, ARG0, ARG1];
my $wheel_id = delete $self->{pipe_to_id}{$id};
my $eval = $self->{evals}{$wheel_id};
while (my ($key, $value) = each %$return) {
$eval->{return}{$key} = $value;
}
return;
}
sub eval_stdin {
my ($self, $wheel_id) = @_[OBJECT, ARG0];
my $wheel = $self->{evals}{$wheel_id}{wheel};
$wheel->shutdown_stdin();
return;
}
sub eval_sig_child {
my ($self, $pid) = @_[OBJECT, ARG1];
my $wheel_id = delete $self->{pid_to_id}{$pid};
my $eval = delete $self->{evals}{$wheel_id};
$poe_kernel->alarm_remove($eval->{alarm_id});
unlink $eval->{pipe_name};
# getrusage() in the child doesn't provide wallclock time, so we do it
$eval->{return}{real_time} = sprintf('%.2f', time() - $eval->{start_time});
if (defined $self->{clients}{$eval->{client_id}}) {
my $client = $self->{clients}{$eval->{client_id}};
if ($eval->{return}{error}) {
$client->put({ error => $eval->{return}{error} });
}
elsif (!exists $eval->{return}{result}) {
$client->put({ error => 'Child process died before returning a result.' });
}
else {
$client->put($eval->{return});
}
}
return;
}
sub eval_timeout {
my ($self, $wheel_id) = @_[OBJECT, ARG0];
my $wheel = $self->{evals}{$wheel_id};
$wheel->kill();
return;
}
sub _shutdown {
my ($kernel, $self) = @_[KERNEL, OBJECT];
delete $self->{server};
delete $self->{clients};
$kernel->alarm_remove_all();
return;
}
sub shutdown {
my ($self) = @_;
$poe_kernel->post($self->{session_id}, '_shutdown');
return;
}
1;
=encoding utf8
=head1 NAME
App::EvalServer - Evaluate arbitrary code in a safe environment
=head1 SYNOPSIS
use App::EvalServer;
my $server = App::EvalServer->new(
port => 1234,
timeout => 30,
);
$server->run();
# ...
$server->shutdown();
=head1 DESCRIPTION
This application evaluates arbitrary source code in a safe enviroment. It
listens on a TCP port and accepts JSON data desribing a language and some
code to evaluate. The result of the evaluation and some accompanying
information is then returned as back as JSON data. See L</INPUT> and
L</OUTPUT> for details.
=head1 METHODS
=head2 C<new>
Constructs a new C<App::EvalServer> object. Takes the following optional
argunments:
B<'host'>, the host to listen on (default: 'localhost')
B<'port'>, the port to listen on (default: 14400)
B<'user'>, evaluate code as this user (default: 'nobody')
B<'timeout'>, kill the evaluating process after this many seconds (default: 10)
B<'limit'>, resource limit in megabytes (default: 50)
B<'daemonize'>, daemonize the process
B<'unsafe'>, don't chroot or set resource limits (no root needed). Default is
false.
=head2 C<run>
Runs the server. Takes no arguments.
=head2 C<shutdown>
Shuts down the server. Takes no arguments.
=head1 INPUT
To request an evaluation, you need to send a JSON hash containing the
following keys:
B<'lang'>, a string containing the language module suffix, e.g. 'Perl' for
L<App::EvalServer::Language::Perl|App::EvalServer::Language::Perl>.
B<'code'>, a string containing the code you want evaluated.
=head1 OUTPUT
When your request has been processed, you will receive a JSON hash back. If
no errors occurred B<before> the code was evaluated, the hash will contain the
following keys:
=over 4
=item * B<'result'>, containing the result of the evaluation.
=item * B<'stdout'>, a string containing everything that was printed to the
evaluating process' stdout handle.
=item * B<'stderr'>, a string containing everything that was printed to the
evaluating process' stderr handle.
=item * B<'output'> a string containing the merged output (stdout & stderr)
from the evaluating process.
=item * B<'memory'>, the memory use of the evaluating process (as reported by
L<C<(getrusage())[2]>|BSD::Resource/getrusage>).
=item * B<'real_time'>, the real time taken by the evaluating process.
=item * B<'user_time'>, the user time taken by the evaluating process.
=item * B<'sys_time'>, the sys time taken by the evaluating process.
=back
If an error occurred before the code could be evaluated, the only key you
will get is B<'error'>, which tells you what
went wrong.
=head1 AUTHOR
Hinrik E<Ouml>rn SigurE<eth>sson (hinrik.sig@gmail.com), C<buu>, and probably
others
=head1 LICENSE AND COPYRIGHT
Copyright 2010 Hinrik E<Ouml>rn SigurE<eth>sson
This program is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut