I have a Perl Mojo server running and when posting to a certain url, there is a script that creates a sub process for a very long process (around a minute's time).
This process runs for about 30 seconds then crashes, and here are no exceptions being thrown or any logs being generated.
My natural assumption is that this has something to do with a connection timeout, so I increased the server's timeout. This being said, I'm pretty confident that this has nothing to do with the server process but rather the perl script itself timing out.
I came across the docs on the subprocess page that says:
Note that it does not increase the timeout of the connection, so if your forked process is going to take a very long time, you might need to increase that using "inactivity_timeout" in Mojolicious::Plugin::DefaultHelpers.
The DefaultHelpers docs say:
inactivity_timeout
$c = $c->inactivity_timeout(3600);
Use "stream" in Mojo::IOLoop to find the current connection and increase timeout if possible.
Longer version
Mojo::IOLoop->stream($c->tx->connection)->timeout(3600);
but I'm not eactly sure how (or where) to define the inactivity timeout, or what excatly the $c variable is in the docs.
My Code:
sub long_process{
my ($self) = #_;
my $fc = Mojo::IOLoop::Subprocess->new;
$fc->run(
sub {
my #args = #_;
sleep(60);
},[],
);
}
links:
inactivity_timeout
subprocess
Here is a minimal example:
use Mojolicious::Lite;
get '/',
sub {
my $c = shift;
say Mojo::IOLoop->stream($c->tx->connection)->timeout;
$self->inactivity_timeout(60);
say Mojo::IOLoop->stream($c->tx->connection)->timeout;
my $fc = Mojo::IOLoop::Subprocess->new;
$fc->run(
sub {
my #args = #_;
sleep(20);
return 'Hello Mojo!';
},
sub {
my ($subprocess, $err, $result) = #_;
say $result;
$c->stash(result => $result);
$c->render(template => 'foo');
}
);
};
app->start;
__DATA__
## foo.html.ep
%== $result
The second callback passed to run() does the processing when the subprocess has finished.
See Mojo::IOLoop::Subprocess for details.
Related
I'm trying to reuse a previously established websocket connection to avoid the websocket handshake. I found that a custom websocket transaction can be built using build_websocket_tx (more details here), and there's a connection identifier for every websocket connection which can be retrieved using connection subroutine defined in Mojo::Transaction (more details here). Can I somehow combine both of these to re use the connection? Is there another way to do so?
PS: Websocket connections are supposed to be consistent and reusable. But Mojolicoious doesn't provide any such options for websocket connections.
EDIT
Example code without connection re-use.
#!/usr/bin/perl
use strict;
use warnings;
use Mojo::UserAgent;
use JSON qw |encode_json|;
my $ua = Mojo::UserAgent->new;
my $url = "wss://trello.com/1/Session/socket";
$| = 1;
sub _connect {
my $req = {
type => "ping",
reqid=> 0
};
$ua->websocket(
$url => sub {
my ($ua, $tx) = #_;
die "error: ", $tx->res->error->{message}, "\n" if $tx->res->error;
die 'Not a websocket connection' unless $tx->is_websocket;
# Connection established.
$tx->on(
message => sub {
my ($tx, $msg) = #_;
print "$msg\n";
$tx->closed; #Close connection
});
$tx->send(encode_json($req));
});
}
sub reuse_conn {
# Re use connection
}
_connect();
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
Preliminaries: to run a Mojolicious client script with debugging information:
MOJO_EVENTEMITTER_DEBUG=1 MOJO_USERAGENT_DEBUG=1 perl mua.pl
As at version 7.43, Mojo::UserAgent has built-in connection pooling but specifically refuses to use it for WebSockets. This may well be because as you said, WebSockets is stateful, and if the UserAgent blindly reused connections, that could cause chaos. However, if your application knows how to safely reuse them, that is a different matter.
This question came up recently in the IRC channel for Mojolicious, and sri, the author, said:
16:28 sri mohawk: some frameworks like phoenix have their own higher level protocol on top of websockets to multiplex multiple channels https://hexdocs.pm/phoenix/channels.html
16:28 sounds like that's what you want
16:28 mojolicious should have something like that, but doesn't yet
[...]
16:42 sri it's not hard to build on top of mojolicious, but for now you have to do that yourself
16:42 ultimately i'd hope for us to have it in core, without the message bus part
16:43 but channel management and routing
[...]
16:50 jberger mohawk I did write Mojolicious::Plugin::Multiplex which might help
16:51 For an example of a higher level tool
I acknowledge OP said:
The only way I was able to reuse connection was by storing the transaction object and use it in subsequent calls.
However, as the code currently is, it appears this is the only way. This code demonstrates how to make, maintain, and use your own connection pool:
#!/usr/bin/perl
use strict;
use warnings;
use Mojo::UserAgent;
use Time::HiRes qw(time);
$| = 1;
my $REQ = {
type => "ping",
reqid => 0,
};
my $URL = "wss://trello.com/1/Session/socket";
my $SECONDS = 2;
my $POOL_SIZE = 5;
my $ua = Mojo::UserAgent->new;
my #pool;
sub make_conn {
my ($ua, $url, $pool) = #_;
$ua->websocket($URL => sub {
my (undef, $tx) = #_;
die "error: ", $tx->res->error->{message}, "\n" if $tx->res->error;
die 'Not a websocket connection' unless $tx->is_websocket;
push #$pool, $tx;
});
}
# pool gets pushed onto, shifted off, so using recently-used connection
sub send_message {
my ($pool, $request, $start) = #_;
my $tx = shift #$pool;
die "got bad connection" unless $tx; # error checking needs improving
$tx->once(message => sub {
my (undef, $msg) = #_;
print "got back: $msg\n";
print "took: ", time - $start, "\n";
push #$pool, $tx;
});
$tx->send({json => $request});
}
make_conn($ua, $URL, \#pool) for (1..5); # establish pool
# every 2 secs, send a message
my $timer_cb;
$timer_cb = sub {
my $loop = shift;
print "every $SECONDS\n";
send_message(\#pool, $REQ, time);
$loop->timer($SECONDS => $timer_cb);
};
Mojo::IOLoop->timer($SECONDS => $timer_cb);
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
At a high level, it works like this:
make 5 connections in the pool
send_message uses the least-recently-used connection in that pool
send a message every two seconds, registering a one-time "on message" callback to deal with the response
For the sake of simplicity, it does not check connections are still working when it gets them from the pool, and relies on the first two-second delay to initialise all 5 connections.
The use of time calls demonstrates the speed gain from using this pool. Your provided code takes (on my system) around 300ms to start up the connection, then send and receive. Using the pool, it is taking around 120ms.
I have a script based on Term::ReadLine and LWP::UserAgent
The logic is like this,
while (defined ($_ = $term->readline('console> ')))
{
next unless $_; chomp;
if ($_ eq 'exit')
{
last;
}
&run ($_);
}
sub run {
my $ua = LWP::UserAgent->new;
my $resp = $ua->get (...);
say $resp->content;
}
In run it will do a LWP request. Now If I press CTRL + C, not only the LWP is terminated, the whole perl script is terminated as well.
I wanted to kill the LWP request only. Any ideas?
I can add a SIGINT handler, but I don't know what the handler should do
Convert the signal into an exception.
local $SIG{INT} = sub { die "SIGINT\n" };
Generally, one would then wrap the code in an eval BLOCK, but LWP::UserAgent catches these exceptions and returns an error response.
For example,
use LWP::UserAgent;
my $ua = LWP::UserAgent->new();
my $response = do {
local $SIG{INT} = sub { die "SIGINT\n" };
$ua->get("http://localhost/zzz.crx")
};
say $response->is_success ? "Successful" : "Unsuccessful";
say $response->code;
say $response->status_line;
Output if no SIGINT received:
Successful
200
200 OK
Output if SIGINT received:
Unsuccessful
500
500 SIGINT
One way to stop code is to run it in a child process and kill that child in the parent's signal handler when SIGINT is received by the parent. The parent keeps running since the signal is handled.
use warnings;
use strict;
use feature 'say';
$SIG{INT} = \&sigint_handler; # or: $SIG{INT} = sub { ... };
say "Parent $$ start.";
my $pid = run_proc();
my $gone_pid = waitpid $pid, 0; # check status, in $?
say "Parent exiting";
sub run_proc
{
my $pid = fork // die "Can't fork: $!";
if ($pid == 0) { # child process
say "\tKid, sleep 5 (time for Ctrl-C)"; # run your job here
sleep 5;
say "\tKid exiting.";
exit;
}
return $pid;
}
sub sigint_handler {
if ($pid and kill 0, $pid) {
say "Got $_[0], send 'kill TERM' to child process $pid.";
my $no_signalled = kill 15, $pid;
}
else { die "Got $_[0]" } # or use exit
}
A good deal of the code is for diagnostic prints. Some comments follow
The kill only sends a signal. It does not in any way ensure that the process terminates. Check this with kill $pid, 0, which returns true if the process has not been reaped (even if it's a zombie). On my system TERM is 15, and even though this is very common please check.
The signal could come at a time when the child is not running. The handler first checks whether the $pid is out there and if not it dies/exits, respecting SIGINT. Change as appropriate.
After the fork the parent drops past if ($pid == 0) and returns the $pid right away.
You can install $SIG{TERM} in the child, where it can clean up if it needs to exit orderly.
The SIGINT handler will run out of the child as well, so "Got $_[0] ..." is printed twice. If this is a concern add a handler to the child to ignore the signal, $SIG{INT} = 'IGNORE';. With this in place and with Ctrl-C hit while the child is running, the output is
Parent 9334 start.
Kid, sleep 5 (time for Ctrl-C)
^CGot INT, send 'kill TERM' to child process 9335.
Parent exiting
The status of the child once it exited can be checked via $?, see system and in perlvar.
Documentation: fork (and exec, system), %SIG in perlvar, waitpid, parts of perlipc, kill.
If the job done in the child needed to communicate with the parent then there would be more to do. However, the code snippet added to the question indicates that this is not the case.
You need to provide a callback in your call to $ua->request. Issuing die in that callback will terminate the transfer.
You then just need to set a flag variable in your Ctrl-C signal handler, and die in your callback if that flag is set.
I'll write some code when I get back to a PC, and when you have shown what your run subroutine does.
Here's some code that looks right, but I can't test it at present
Beware that run is a dire identifier for any subroutine, especially one that starts a network transfer and prints the result
sub run {
my ($url) = #_;
my $die;
local $SIG{INT} = sub { $die = 1 };
my $ua = LWP::UserAgent->new;
my $resp = $ua->get(
$url,
':content_cb' => sub {
die "Interrupted LWP transfer" if $die;
my ($data, $resp, $proto) = #_;
print $data;
},
':read_size_hint' => 1024
);
print "\n"; # Emulate additional newline from `say`
}
Note that reducing :read_size_hint will cause the callback to be called more frequently with smaller chunks of data. That will improve the response to Ctrl-C but reduce the efficiency of the transfer
I'm writing a wrapper to an external command ("sox", if this can help) with Perl "Tk".
I need to run it asynchronously, of course, to avoid blocking tk's MainLoop().
But, I need to read it's output to notify user about command's progress.
I am testing a solution like this one, using IPC::Open3:
{
$| = 1;
$pid = open3(gensym, ">&STDERR", \*FH, $cmd) or error("Errore running command \"$cmd\"");
}
while (defined($ch = FH->getc)) {
notifyUser($ch) if ($ch =~ /$re/);
}
waitpid $pid, 0;
$retval = $? >> 8;
POSIX::close($_) for 3 .. 1024; # close all open handles (arbitrary upper bound)
But of course the while loop blocks MainLoop until $cmd does terminate.
Is there some way to read output handle asynchronously?
Or should I go with standard fork stuff?
The solution should work under win32, too.
For non-blocking read of a filehandle, take a look at Tk::fileevent.
Here's an example script how one can use a pipe, a forked process, and fileevent together:
use strict;
use IO::Pipe;
use Tk;
my $pipe = IO::Pipe->new;
if (!fork) { # Child XXX check for failed forks missing
$pipe->writer;
$pipe->autoflush(1);
for (1..10) {
print $pipe "something $_\n";
select undef, undef, undef, 0.2;
}
exit;
}
$pipe->reader;
my $mw = tkinit;
my $text;
$mw->Label(-textvariable => \$text)->pack;
$mw->Button(-text => "Button", -command => sub { warn "Still working!" })->pack;
$mw->fileevent($pipe, 'readable', sub {
if ($pipe->eof) {
warn "EOF reached, closing pipe...";
$mw->fileevent($pipe, 'readable', '');
return;
}
warn "pipe is readable...\n";
chomp(my $line = <$pipe>);
$text = $line;
});
MainLoop;
Forking may or may not work under Windows. Also one needs to be cautious when forking within Tk; you must make sure that only one of the two processes is doing X11/GUI stuff, otherwise bad things will happen (X11 errors, crashes...). A good approach is to fork before creating the Tk MainWindow.
I would like to do some non-blocking SSH to a couple of thousand machines that i'm tracking (my own machines), I have a Dancer application up and running, and I'm willing to use AnyEvent::timer to execute SSH commands asynchronously (each machine has its own polling interval, and I don't want one machine to wait for another to complete with its SSH work).
I'm wondering, what is the best way to act asynchronously in a synchronous environment?
It is not very good idea to run any external commands from within your web scripts.
For one, should your external call block or crash for any reason, it will create bad experience for the user (even it that user is just you).
Then, running external commands as web user may have a lot of security implications - I would think your web user most likely has passwordless ssh set up, doesn't it? What if someone figures out some security hole in your script and manages to use it to ssh into your servers?
Instead, you should create separate service or process which will regularly poll your servers status using ssh (or what else) and save results of that scan into database - Postgres or MySQL.
Then, change your Dancer app to display collected results from database, rather than doing live ssh request. This way it will be very fast and secure.
I could not be a good idea but it is possible. I have a big Dancer application to execute scripts remotely and I'm doing it with fork and Net::SSH2. I tried with thread but there are some modules that are not thread-safe so I recommend to use fork.
I have some comments in my blog http://perlondancer.blogspot.mx/2014/04/executing-remote-commands-from-dancer.html and in this gist is the code example below: https://gist.github.com/johandry/11197516
#!/usr/bin/env perl
use strict;
use warnings;
use Dancer;
use Net::SSH2;
sub execCommand ($$) {
my ( $ssh2, $cmd ) = #_;
my %args=(
timeout => 1_000, # polling timeout
bufsize => 10_240, # read buffer size when polling
);
$ssh2->blocking(1); #needed for ssh->channel
my $chan=$ssh2->channel(); # create SSH2 channel
if ($ssh2->error()) {
return (undef, undef, 100);
}
# exec $cmd (caveat: only one command line can be executed over this channel. No "ls -l;whoami" combo. Use ssh->shell instead.
unless ($chan->exec($cmd)) {
return (undef, undef, 500);
}
# defin polling context: will poll stdout (in) and stderr (ext)
my #poll = ( { handle => $chan, events => ['in','ext'] } );
my %std=(); # hash of strings. store stdout/stderr results
$ssh2->blocking( 0 ); # needed for channel->poll
while(!$chan->eof) { # there still something to read from channel
$ssh2->poll( $args{'timeout'}, [ #poll ] ); # if any event, it will be store into $poll;
my( $n, $buf ); # number of bytes read (n) into buffer (buf)
foreach my $poll ( #poll ) { # for each event
foreach my $ev ( qw( in ext ) ) { #for each stdout/stderr
next unless $poll->{revents}{$ev};
#there are something to read here, into $std{$ev} hash
if( $n = $chan->read( $buf, $args{'bufsize'}, $ev eq 'ext' ) ) { #got n byte into buf for stdout ($ev='in') or stderr ($ev='ext')
$std{$ev}.=$buf;
}
} #done foreach
}
}
$chan->wait_closed(); #not really needed but cleaner
my $exit_code=$chan->exit_status();
$chan->close(); #not really needed but cleaner
$ssh2->blocking(1); # set it back for sanity (future calls)
return ($std{'in'},$std{'ext'},$exit_code);
}
sub execute ($$$$) {
my ($ip, $username, $password, $cmd) = #_;
my $pid = fork();
if ($pid) {
# This is the parent (DANCER)
debug "Process started with PID $pid\n";
} elsif ( $pid == 0 ) {
# This is the child
my $ssh2 = Net::SSH2->new();
$ssh2->connect( $ip ) or debug("Cannot connect to $ip");
my $publicKeyFile = './id_rsa.pub'; # path(setting('appdir'), 'db', 'id_rsa.pub'); # I prefer to copy the public key in your app dir due to permissions issues
my $privateKeyFile = './id_rsa'; # path(setting('appdir'), 'db', 'id_rsa'); # I prefer to copy the private key in your app dir due to permissions issues
if ( $ssh2->auth_publickey( $username, $publicKeyFile, $privateKeyFile, $password ) ) {
my ($stdout, $stderr, $exitcode) = execCommand($ssh2, $cmd);
} else {
debug "Could not authenticate to $ip with $username";
}
$ssh2->disconnect();
} else {
debug "Could not fork: $!\n";
}
}
set logger => "console";
set log => "core";
set show_errors => 1;
get '/uptime/:ip' => sub {
my $username = "the username";
my $password = "the password";
execute(param('ip'), $username, $password, "uptime > /tmp/dancer_example.txt");
return 'uptime is running';
};
dance;
true;
Net::SSH2 can be used asynchronously, but it is quite buggy and crashes often. Forget about using it for running thousands (or just hundreds) of connections in parallel on the same process. It may be ok if you use it wrapped in new processes as recomended by #Johandry, but then you can just run the ssh command using AnyEvent::Util::run_cmd.
Net::OpenSSH is another Perl module that can be used asynchronously. It shouldn't be too difficult to integrate it inside AnyEvent.
I'm currently writing an IRC bot. The scripts are loaded as perl modules in ZNC but the bot gets disconnected with an Input/Output error if I create a forked process. This is a working example script without fork, but this causes the bot to freeze until the script finishes doing its task.
package imdb;
use warnings;
use strict;
sub new
{
my ($class) = #_;
my $self = {};
bless( $self, $class );
return( $self );
}
sub OnChanMsg
{
my ($self, $nick, $channel,$text) = #_;
#unless (my $pid = fork()) {
my $result = a_slow_process($text);
ZNC::PutIRC( "PRIVMSG $channel :$result" );
# exit;
#}
return( ZNC::CONTINUE );
}
sub OnShutdown
{
my ( $me ) = #_;
}
sub a_slow_process {
my $input = shift;
sleep 10;
return "You said $input.";
}
1;
The fork code that is causing the error is commented out. How do I fix this?
Edited to add: I was told that ZNC::PutIRC should not be put in the child process.
A fork() call has effects on open file and socket handles, including:
File descriptors (and sometimes locks on
those descriptors) are shared, while everything else is copied.
...
Beginning with v5.6.0, Perl will attempt to flush all files
opened for output before forking the child process, but this
may not be supported on some platforms (see perlport). To be
safe, you may need to set $| ($AUTOFLUSH in English) or call
the "autoflush()" method of "IO::Handle" on any open handles in
order to avoid duplicate output.
and in general it is not a good idea to set up a socket connection in one process and try to read/write on that connection in a child process.
A workaround might be to make a new ZNC connection in the child process (after a_slow_process() is done), write your private message, and then close the new connection.
If you're not adverse to rewriting your module in c++, znc has a CExecSock which wraps popen2() and should do what you need. You can look in the shell.cpp module for example usage.