I am Perl beginner and I am fighting with websockets at the moments. After a lot of reading, trying and copy-pasting I got this code to work:
use strict;
use warnings;
use utf8;
use Data::Dumper;
use IO::Async::Loop;
use IO::Async::Timer::Periodic;
use Net::Async::WebSocket::Client;
use Protocol::WebSocket::URL;
my ($url, $msg, $last_update);
$url = 'ws://127.0.0.1/stream';
$msg = 'get_lists';
my $uri = Protocol::WebSocket::URL->new->parse($url);
my $loop = IO::Async::Loop->new;
my $client = Net::Async::WebSocket::Client->new(
on_frame => sub {
my ($self, $frame) = #_;
chomp($frame);
$last_update = time(); # use this in timer below
# do something else
}
);
$loop->add($client);
$client->connect(
host => $uri->host,
service => $uri->port,
url => $url,
on_connected => sub {
warn "Connection established";
if ($msg) {
$client->send_frame("$msg\n");
}
},
on_connect_error=> sub { die "CONNECT: ".Dumper \#_; },
on_resolve_error=> sub { die "RESOLVE: ".Dumper \#_; },
on_fail => sub { die "FAIL: ".Dumper \#_; },
on_read_eof => sub {
$loop->remove($client);
# reconnect?
}
);
# is the connection to socket is still open?
# check every 30 seconds if $last_update was not updated
my $timer = IO::Async::Timer::Periodic->new(
interval=> 30,
on_tick => sub {
if (!$last_update || time()-30 > $last_update) {
warn "Connection probably dead. No new data for 20 seconds.";
## check connection
## and reconnect if needed
}
},
);
$timer->start;
$loop->add($timer);
$loop->loop_forever;
I need one more thing here and I am not sure how to solve this:
I found some info like https://stackoverflow.com/a/12091867/1645170 but I do not understand how to put SO_KEEPALIVE in my code. I should probably make my own IO::Socket connection and somehow pass it to Async::Net::WebSocket but I was not able to do it. Actually I don't really have an idea how shoud I do this. Obviously beginner's problems.
I tried the second approach with a timer which should check every 30 seconds whether the connection is open (if no new data came through socket). Again, same problem but from the other side: not sure how to check with the above code whether the connection is open.
I could make a basic IO::Socket connection but I would like to do somehow with the above code because I like how Net::Async::WebSocket does it with events (on_read-eof, on_frame etc).
How to check if it is still works?
Create a "heartbeat". Send a "ping" at every x second from a client and wait until a "pong" gets back. Die if timeout reached.
On the server you could add your own socket (from one of the examples).
If hope it will help you.
my $serversock = IO::Socket::INET->new(
LocalHost => "127.0.0.1",
Listen => 1,
) or die "Cannot allocate listening socket - $#";
$serversock->setsockopt(SOL_SOCKET, SO_KEEPALIVE, 1);
my #serverframes;
my $acceptedclient;
my $server = Net::Async::WebSocket::Server->new(
handle => $serversock,
Related
First of all I would thank you guys not offering a work around as a solution (although it would be cool to know other ways to do it). I was setting up tg-master project (telegram for cli) to be used by check_mk alert plugin. I found out that telegram runs on a stdin/stdout proccess so I tought it would be cool to "glue" it, so i wrote with a lot of building blocks from blogs and cpan the next 2 pieces of code. They already work (i need to handle broken pipes sometimes) but I was wondering if sharing this could come from some experts new ideas.
As you could see my code relies on a eval with a die reading from spawned process, and I know is not the best way to do it. Any suggestions? :D
Thank you guys
Server
use strict;
use IO::Socket::INET;
use IPC::Open2;
use POSIX;
our $pid;
use sigtrap qw/handler signal_handler normal-signals/;
sub signal_handler {
print "what a signal $!\nlets kill $pid\n";
kill 'SIGKILL', $pid;
#die "Caught a signal $!";
}
# auto-flush on socket
$| = 1;
# creating a listening socket
my $socket = new IO::Socket::INET(
LocalHost => '0.0.0.0',
LocalPort => '7777',
Proto => 'tcp',
Listen => 5,
Reuse => 1
);
die "cannot create socket $!\n" unless $socket;
print "server waiting for client connection on port 7777\n";
my ( $read_proc, $write_proc );
my ( $uid, $gid ) = ( getpwnam "nagios" )[ 2, 3 ];
POSIX::setgid($gid); # GID must be set before UID!
POSIX::setuid($uid);
$pid = open2( $read_proc, $write_proc, '/usr/bin/telegram' );
#flush first messages;
eval {
local $SIG{ALRM} = sub { die "Timeout" }; # alarm handler
alarm(1);
while (<$read_proc>) { }
};
while (1) {
my $client_socket = $socket->accept();
my $client_address = $client_socket->peerhost();
my $client_port = $client_socket->peerport();
print "connection from $client_address:$client_port\n";
# read until \n
my $data = "";
$data = $client_socket->getline();
# write to spawned process stdin the line we got on $data
print $write_proc $data;
$data = "";
eval {
local $SIG{ALRM} = sub { die "Timeout" }; # alarm handler
alarm(1);
while (<$read_proc>) {
$client_socket->send($_);
}
};
# notify client that response has been sent
shutdown( $client_socket, 1 );
}
$socket->close();
Client
echo "contact_list" | nc localhost 7777
or
echo "msg user#12345 NAGIOS ALERT ... etc" | nc localhost 7777
or
some other perl script =)
If you are going to implement a script that performs both reads and writes from/to different handles, consider using select (the one defined as select RBITS,WBITS,EBITS,TIMEOUT in the documentation). In this case you will totally avoid using alarm with a signal handler in eval to handle a timeout, and will only have one loop with all of the work happening inside it.
Here is an example of a program that reads from both a process opened with open2 and a network socket, not using alarm at all:
use strict;
use warnings;
use IO::Socket;
use IPC::Open2;
use constant MAXLENGTH => 1024;
my $socket = IO::Socket::INET->new(
Listen => SOMAXCONN,
LocalHost => '0.0.0.0',
LocalPort => 7777,
Reuse => 1,
);
# accepting just one connection
print "waiting for connection...\n";
my $remote = $socket->accept();
print "remote client connected\n";
# simple example of the program writing something
my $pid = open2(my $localread, my $localwrite, "sh -c 'while : ; do echo boom; sleep 1 ; done'");
for ( ; ; ) {
# cleanup vectors for select
my $rin = '';
my $win = '';
my $ein = '';
# will wait for a possibility to read from these two descriptors
vec($rin, fileno($localread), 1) = 1;
vec($rin, fileno($remote), 1) = 1;
# now wait
select($rin, $win, $ein, undef);
# check which one is ready. read with sysread, not <>, as select doc warns
if (vec($rin, fileno($localread), 1)) {
print "read from local process: ";
sysread($localread, my $data, MAXLENGTH);
print $data;
}
if (vec($rin, fileno($remote), 1)) {
print "read from remote client: ";
sysread($remote, my $data, MAXLENGTH);
print $data;
}
}
In the real production code you will need to carefully check for errors returned by various function (socket creation, open2, accept, and select).
I'm following this guide explaining how to do a server using IO::Async but I'm having issues with my client code. I have it where I send first then receive. This makes me press enter on each client before receiving any data. I figured I'd have to listen till I wanted to type something but I'm not really sure how. Below is my current client code.
use IO::Socket::INET;
# auto-flush on socket
$| = 1;
# create a connecting socket
my $socket = new IO::Socket::INET (
PeerHost => 'localhost',
PeerPort => '12345',
Proto => 'tcp',
);
die "cannot connect to the server $!\n" unless $socket;
print "My chat room client. Version One.\n";
while (1) {
my $data = <STDIN>;
$socket->send($data);
my $response = "";
$socket->recv($response, 1024);
print ">$response";
last if (index($data, "logout") == 0);
}
$socket->close();
I actually had this problem myself a few weeks ago when trying to make a client/server chat for fun.
Put it off until now.
The answer to your problem of having to hit enter to receive data, is that you need to use threads. But even if you use threads, if you do $socket->recv(my $data, 1024) you won't be able to write anything on the command line.
This isn't using your code, but here is my solution after banging my head against a wall for the last 24hrs. I wanted to add this as an answer, because though the question is out there on stackoverflow, none of the answers seemed to show how to use IO::Select.
Here is the server.pl script, it does not use threading:
#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket::INET;
use IO::Select;
$| = 1;
my $serv = IO::Socket::INET->new(
LocalAddr => '0.0.0.0',
LocalPort => '5000',
Reuse => 1,
Listen => 1,
);
$serv or die "$!";
print 'server up...';
my $sel = IO::Select->new($serv); #initializing IO::Select with an IO::Handle / Socket
print "\nAwaiting Connections\n";
#can_read ( [ TIMEOUT ] )
#can_write ( [ TIMEOUT ] )
#add ( HANDLES )
#http://perldoc.perl.org/IO/Select.html
while(1){
if(my #ready = $sel->can_read(0)){ #polls the IO::Select object for IO::Handles / Sockets that can be read from
while(my $sock = shift(#ready)){
if($sock == $serv){
my $client = $sock->accept();
my $paddr = $client->peeraddr();
my $pport = $client->peerport();
print "New connection from $paddr on $pport";
$sel->add($client); #Adds new IO::Handle /Socket to IO::Select, so that it can be polled
#for read/writability with can_read and can_write
}
else{
$sock->recv(my $data, 1024) or die "$!";
if($data){
for my $clients ($sel->can_write(0)){
if($clients == $serv){next}
print $clients $data;
}
}
}
}
}
}
And the client.pl, which uses threads:
#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket::INET;
use threads;
use IO::Select;
$| = 1;
my $sock = IO::Socket::INET->new("localhost:5000");
$sock or die "$!";
my $sel = IO::Select->new($sock);
print "Connected to Socket ". $sock->peeraddr().":" . $sock->peerport() . "\n";
#This creates a thread that will be used to take info from STDIN and send it out
#through the socket.
threads->create(
sub {
while(1){
my $line = <>;
chomp($line);
for my $out (my #ready = $sel->can_write(0)){
print $out $line;
}
}
}
);
while(1){
if(my #ready = $sel->can_read(0)){
for my $sock(#ready){
$sock->recv(my $data, 1024) or die $!;
print "$data\n" if $data;
}
}
}
There is one other problem that arises though, when the client receives data and prints it to the console, your cursor goes to a new line, leaving behind any characters you had typed.
Hope this helps and answers your question.
For a simple "just send from STDIN, receive to STDOUT" client, you could use any of telnet, nc or socat. These will be simple enough to use for testing.
$ telnet localhost 12345
$ nc localhost 12345
$ socat stdio tcp:localhost:12345
If you actually want to write something in Perl, because you want to use it as an initial base to start a better client from, you probably want to base that on IO::Async. You could then use the netcat-like example here. That will give you a client that looks-and-feels a lot like a simple netcat.
I am guessing you need to set the MSG_DONTWAIT flag on your recv call, and print the response only if it is non-null.
$socket->recv($response, 1024, MSG_DONTWAIT);
print ">$response" if ($response ne "");
I have a piece of code that creates a UNIX domain socket using IO::Socket::UNIX and gives it to an instance of IO::Async::Listener to handle listening on the socket and notifying on receiving data. The IO::Async::Listener, then, is added to a IO::Async::Loop event loop instance.
The sockets are created dynamically in a controlled manager, of course.
On a certain condition, I'd like to remove the socket from the event loop (completely delete it, or temporarily disable it on other conditions if possible) but I don't know how.
IO::Async::Loop offers to remove IO::Async::Notifier objects from the event loop via $loop->remove( $notifier ) but creating the notifier was handled internally by IO::Async::Listener (via IO::Async::Stream, I presume?). Even on Ctrl-C of my script, the socket file is not deleted, do I just have to manually close $socket and unlink( $path ) of the socket file?
Here's an abstract code of the desired behavior:
#!/usr/bin/perl
use IO::Async::Loop;
use IO::Async::Listener;
use IO::Socket::UNIX;
my $loop = IO::Async::Loop->new;
my $listener = IO::Async::Listener->new(
on_stream => sub {
my ( undef, $stream ) = #_;
$stream->configure(
on_read => sub {
my ( $self, $buffref, $eof ) = #_;
$self->write( $buffref );
$buffref = "";
return 0;
},
);
$loop->add( $stream );
},
);
$loop->add( $listener );
my $socket = IO::Socket::UNIX->new(
Local => "echo.sock",
Listen => 1,
) || die "Cannot make UNIX socket - $!\n";
$listener->listen(
handle => $socket,
);
my $condition = true;
while($condition) {
// this is probably wrong
$loop->remove( $listener );
$condition = false;
}
You seem to have two related questions here.
You can remove the listener object from the loop by using the loop's remove method:
$loop->remove( $listener )
However, removing the listener from the loop won't unlink the socket node from the fileystem. For that you will need the unlink code you suggested.
Personally, in such code as creates sockets like this, I make use of an END block:
my $path = "echo.sock";
my $socket = IO::Socket::UNIX->new(
Local => $path,
Listen => 1,
) || die "Cannot make UNIX socket - $!\n";
END { $socket and unlink $path }
$SIG{INT} = $SIG{TERM} = sub { exit 1 };
The $SIG line is required to ensure that SIGINT and SIGTERM still run the END block, rather than just causing the perl process to immediately terminate.
Finally, you should note that you can use a neater form of the listen method, rather than explicitly creating the UNIX socket in your case, you can just
my $listener = ...
$loop->add( $listener );
$listener->listen(
addr => {
family => "unix",
socktype => "stream",
path => "echo.sock",
},
);
Though again in this case you will still need the END block.
I have a simple script that should bind to an SMSC and listen for incoming messages. The problem I'm having is that it will time out if it doesn't receive any messages.
Here is the script:
#!/usr/bin/perl
use Net::SMPP;
use Data::Dumper;
$Net::SMPP::trace = 1;
$smpp = Net::SMPP->new_receiver('--removed--',
port => '--removed--',
system_id => '--removed--',
password => '--removed--',
) or die;
while (1)
{
$pdu = $smpp->read_pdu() or die;
print "Received #$pdu->{seq} $pdu->{cmd}:". Net::SMPP::pdu_tab->{$pdu->{cmd}}{cmd} ."\n";
print "From: $pdu->{source_addr}\nTo: $pdu->{destination_addr}\nData: $pdu->{data}\n";
print "Messsage: $pdu->{short_message}\n\n";
}
Here's the error I'm getting:
premature eof reading from socket at /usr/lib/perl5/site_perl/5.8.8/Net/SMPP.pm line 2424.
$VAR1 = undef;
And here's the relevant sub from SMPP.pm:
sub read_hard {
my ($me, $len, $dr, $offset) = #_;
while (length($$dr) < $len+$offset) {
my $n = length($$dr) - $offset;
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm ${*$me}{enquire_interval} if ${*$me}{enquire_interval};
warn "read $n/$len enqint(${*$me}{enquire_interval})" if $trace>1;
while (1) {
$n = $me->sysread($$dr, $len-$n, $n+$offset);
next if $! =~ /^Interrupted/;
last;
}
alarm 0;
};
if ($#) {
warn "ENQUIRE $#" if $trace;
die unless $# eq "alarm\n"; # propagate unexpected errors
$me->enquire_link(); # Send a periodic ping
} else {
if (!defined($n)) {
warn "error reading header from socket: $!";
${*$me}{smpperror} = "read_hard I/O error: $!";
${*$me}{smpperrorcode} = 1;
return undef;
}
#if ($n == 0) { last; }
if (!$n) {
warn "premature eof reading from socket";
${*$me}{smpperror} = "read_hard premature eof";
${*$me}{smpperrorcode} = 2;
return undef;
#return 0;
}
}
}
#warn "read complete";
return 1;
}
In the sub, the if statement it's hitting is the one where $n is 0 or undef.
My guess is that the socket is timing out and disconnecting. How can I keep the listener up indefinitely?
In addition, this listener blocks while waiting for a pdu. Is there a way to listen without blocking?
I'm a Telecom Engineer who does programming on the side, and I've gone through all the material I could find but couldn't find an answer.
It looks as if the sysread() call simply returns 0. It can do that only, if the connection status is known to be disconnected. Since your side did not disconnect or timeout, i would deduce that the remote side disconnected. If a timeout would have occured on your side, you should not have been able to see the premature eof... message.
So, you are already 'keeping the listener up indefinitely', since you do not set the enquire_interval option.
Regarding 'Is there a way to listen without blocking?' the description section describes asynchronous mode at the end: Module can also be used asynchronously by specifying async=>1 to the constructor. You have to implement the data polling then yourself.
Have you tried to set a parameter for the enquire link (SMPP ping) timeout?
On your new_receiver, verify if "enquire_interval" parameter exists and set it to 15 seconds, for example...
I have tried with new_transceiver() method, and it works.
my $smpp = Net::SMPP->new_transceiver(
$self->host,
port => $self->port,
system_id => $self->user,
password => $self->password,
smpp_version => $self->version,
interface_version => $self->interface_version,
enquire_interval => $self->timeout,
addr_ton => $self->addr_ton,
addr_npi => $self->addr_npi,
source_addr => $self->source_addr,
source_addr_ton => $self->source_addr_ton,
source_addr_npi => $self->source_addr_npi,
dest_addr_ton => $self->dest_addr_ton,
dest_addr_npi => $self->dest_addr_npi,
system_type => $self->system_type,
facilities_mask => $self->facilities_mask
) or die "Could not connect to $self->host: $!";
It (Net::SMPP) handles enquire link automaticallly.
I am also receiving the same error of premature termination.
For blocking, you can fork or thread another process and both can run parallel. There is no way around the blocking.
I am trying to implement a request to an unreliable server. The request is a nice to have, but not 100% required for my perl script to successfully complete. The problem is that the server will occasionally deadlock (we're trying to figure out why) and the request will never succeed. Since the server thinks it is live, it keeps the socket connection open thus LWP::UserAgent's timeout value does us no good what-so-ever. What is the best way to enforce an absolute timeout on a request?
FYI, this is not an DNS problem. The deadlock has something to do with a massive number of updates hitting our Postgres database at the same time. For testing purposes, we've essentially put a while(1) {} line in the servers response handler.
Currently, the code looks like so:
my $ua = LWP::UserAgent->new;
ua->timeout(5); $ua->cookie_jar({});
my $req = HTTP::Request->new(POST => "http://$host:$port/auth/login");
$req->content_type('application/x-www-form-urlencoded');
$req->content("login[user]=$username&login[password]=$password");
# This line never returns
$res = $ua->request($req);
I've tried using signals to trigger a timeout, but that does not seem to work.
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm(1);
$res = $ua->request($req);
alarm(0);
};
# This never runs
print "here\n";
The final answer I'm going to use was proposed by someone offline, but I'll mention it here. For some reason, SigAction works while $SIG(ALRM) does not. Still not sure why, but this has been tested to work. Here are two working versions:
# Takes a LWP::UserAgent, and a HTTP::Request, returns a HTTP::Request
sub ua_request_with_timeout {
my $ua = $_[0];
my $req = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)
use Sys::SigAction qw( timeout_call );
our $res = undef;
if( timeout_call( 5, sub {$res = $ua->request($req);}) ) {
return HTTP::Response->new( 408 ); #408 is the HTTP timeout
} else {
return $res;
}
}
sub ua_request_with_timeout2 {
print "ua_request_with_timeout\n";
my $ua = $_[0];
my $req = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)
my $timeout_for_client = $ua->timeout() - 2;
our $socket_has_timedout = 0;
use POSIX;
sigaction SIGALRM, new POSIX::SigAction(
sub {
$socket_has_timedout = 1;
die "alarm timeout";
}
) or die "Error setting SIGALRM handler: $!\n";
my $res = undef;
eval {
alarm ($timeout_for_client);
$res = $ua->request($req);
alarm(0);
};
if ( $socket_has_timedout ) {
return HTTP::Response->new( 408 ); #408 is the HTTP timeout
} else {
return $res;
}
}
You might try LWPx::ParanoidAgent, a subclass of LWP::UserAgent which is more cautious about how it interacts with remote webservers.
Among other things, it allows you to specify a global timeout. It was developed by Brad Fitzpatrick as part of the LiveJournal project.
You can make your own timeout like this:
use LWP::UserAgent;
use IO::Pipe;
my $agent = new LWP::UserAgent;
my $finished = 0;
my $timeout = 5;
$SIG{CHLD} = sub { wait, $finished = 1 };
my $pipe = new IO::Pipe;
my $pid = fork;
if($pid == 0) {
$pipe->writer;
my $response = $agent->get("http://stackoverflow.com/");
$pipe->print($response->content);
exit;
}
$pipe->reader;
sleep($timeout);
if($finished) {
print "Finished!\n";
my $content = join('', $pipe->getlines);
}
else {
kill(9, $pid);
print "Timed out.\n";
}
From what I understand, the timeout property doesn't take into account DNS timeouts. It's possible that you could make a DNS lookup separately, then make the request to the server if that works, with the correct timeout value set for the useragent.
Is this a DNS problem with the server, or something else?
EDIT: It could also be a problem with IO::Socket. Try updating your IO::Socket module, and see if that helps. I'm pretty sure there was a bug in there that was preventing LWP::UserAgent timeouts from working.
Alex
The following generalization of one of the original answers also restores the alarm signal handler to the previous handler and adds a second call to alarm(0) in case the call in the eval clock throws a non alarm exception and we want to cancel the alarm. Further $# inspection and handling can be added:
sub ua_request_with_timeout {
my $ua = $_[0];
my $request = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)`enter code here`
my $timeout_for_client_sec = $ua->timeout();
our $res_has_timedout = 0;
use POSIX ':signal_h';
my $newaction = POSIX::SigAction->new(
sub { $res_has_timedout = 1; die "web request timeout"; },# the handler code ref
POSIX::SigSet->new(SIGALRM),
# not using (perl 5.8.2 and later) 'safe' switch or sa_flags
);
my $oldaction = POSIX::SigAction->new();
if(!sigaction(SIGALRM, $newaction, $oldaction)) {
log('warn',"Error setting SIGALRM handler: $!");
return $ua->request($request);
}
my $response = undef;
eval {
alarm ($timeout_for_client_sec);
$response = $ua->request($request);
alarm(0);
};
alarm(0);# cancel alarm (if eval failed because of non alarm cause)
if(!sigaction(SIGALRM, $oldaction )) {
log('warn', "Error resetting SIGALRM handler: $!");
};
if ( $res_has_timedout ) {
log('warn', "Timeout($timeout_for_client_sec sec) while waiting for a response from cred central");
return HTTP::Response->new(408); #408 is the HTTP timeout
} else {
return $response;
}
}