Perl, websocket in infinite loop - perl

I have a perl script that worked as a “middle men” between a local program and an external interactive website.
The problem is that the external website migrated from plain tcp connection to a websocket connection.
When the server was using tcp, after initial connection, the client (the script) and the server (external website) will go thru a handshake, then the script will send the username and password and server will finally respond with some encryption keys, afterwards the script will go into an infinite loop and waited for data from both connections and then process that data and "print" back to the connections as needed.
I had been able to establish the websocket connection with the server using the Mojo::UserAgent as well as with protocol::websocket, go thru the handshake and the other information exchange (username, password, etc), but I have not been able (or better said: I do not know how) to "throw" the websocket connection into the infinite loop via IO::Select ( The reason I want to use IO::Select is because doing so will require minimal changes to the script, but other suggestions are definitely welcome).
The relevant parts of the script are as follows:
# Creating connection for local program
$lsn=new IO::Socket::INET(
Proto => 'tcp',
LocalPort => 6000,
Listen => 1,
);
unless(defined $lsn){
print"$0: $!\n";
exit 1;
}
print"Waiting for local program connection on port 6000\n";
$server=$lsn->accept;
$lsn->close;
unless(defined $server){
print "$0: Unable to accept incoming connection: $!\n";
exit 1;
}
# At this point, the script is waiting for a connection from
# the local program on port 6000
printf"Connection accepted from %s\n",$server->peerhost;
select $server;
binmode $server;
$stdin=$server;
(select)->autoflush(1);
# Creating connection for external website
$net=new IO::Socket::INET(
Proto => 'tcp',
PeerAddr => $yog,
PeerPort => $yserverport,
);
unless(defined($net)){
print "Can't connect!\n";
exit 1;
}
$net->autoflush(1);
####################################
# Here the script and server will #
# exchange information few times #
####################################
my $sel=new IO::Select($stdin,$net);
$net->autoflush(0);
while (1){
foreach my $i($sel->can_read(0.05)){
if($i==$net){
&dosomething;
$net->flush;
}
else{
&dosomething2;
$net->flush;
}
}
}
The infinite loop examples that I have found, are not suitable in this case because I need to use an infinite loop that can check for incoming data on both connections.

WebSockets require a lot than asimple IO Socket. They require handshakes and data framing. I would review the W3C WebSocket API and then look into using a perl module (Net::WebSocket::Server) to do the heavy lifting. Also, webSockets will only work with the chrome browser using SSL so if are interested in cross compatibility, use Net::WebSocket::Server with IO::Socket::SSL instead and here is a working sample of SSL:
#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket::SSL;
use Net::WebSocket::Server;
my $ssl_server = IO::Socket::SSL->new(
Listen => 5,
LocalPort => 4000,
Proto => 'tcp',
SSL_cert_file => '/var/ssl/cert.crt',
SSL_key_file => '/var/ssl/cert.key',
) or die "failed to listen: $!";
my $port = 6000;
my $origin = 'https://YOURDOMAIN.com';
Net::WebSocket::Server->new(
listen => $ssl_server,
on_connect => sub {
our ($serv, $conn) = #_;
$conn->on(
handshake => sub {
my ($conn, $handshake) = #_;
$conn->disconnect() unless $handshake->req->origin eq $origin;
},
utf8 => sub {
my ($conn, $msg) = #_;
my $MyIP = $conn->ip();
my $MyPORT = $conn->port();
$_->send_utf8($msg) for( $serv->connections() );
},
);
},
)->start;
If you are not concerned with Chrome or SSL here is a working non-SSL example, (It needs use strict and use warnings):
#!/usr/bin/perl
use Net::WebSocket::Server;
my $port = 6000;
Net::WebSocket::Server->new(
listen => $port,
on_connect => sub {
my ($serv, $conn) = #_;
$conn->on(
utf8 => sub {
my ($conn, $msg) = #_;
$_->send_utf8($msg) for( $serv->connections() );
},
);
},
)->start;
Also, if you decide to use the SSL version, make sure to update your client side from ws:// to wss://

Related

AnyEvent tcp server-client example for localhost hangs when not using TLS

While debugging a failed test for AnyEvent on Windows, I created the following script based on test 80_ssltest.t:
use feature qw(say);
use strict;
use warnings;
use AnyEvent::Socket;
use AnyEvent::Handle;
use AnyEvent::TLS;
my $ctx = AnyEvent::TLS->new( cert_file => $0 );
my $server_done = AnyEvent->condvar;
my $client_done = AnyEvent->condvar;
my $server_port = AnyEvent->condvar;
my $host = "127.0.0.1";
my $server = tcp_server(
$host,
undef, # service: must be either a service name or a numeric port number
# (or 0 or undef, in which case an ephemeral port will be used).
#
sub { # This is the accept callback..
my ($fh, $host, $port) = #_;
say "server_accept";
my $hd; $hd = AnyEvent::Handle->new(
#tls => "accept",
#tls_ctx => $ctx,
fh => $fh,
timeout => 8,
on_error => sub {
say "server_error <$_[2]>";
$server_done->send; undef $hd;
},
on_eof => sub {
say "server_eof";
$server_done->send; undef $hd;
}
);
$hd->push_read (
line => sub {
say "server got line <$_[1]>";
}
);
}, # end of accept callback..
sub { # This is the prepare callback
say "server_listen";
$server_port->send ($_[2]);
}
);
my $port = $server_port->recv; # At this point the server should be listening...
my $hd; $hd = AnyEvent::Handle->new(
connect => [$host, $port],
#tls => "connect",
#tls_ctx => $ctx,
timeout => 8,
on_connect => sub {
say "client_connect";
},
on_error => sub {
say "client_error <$_[2]>";
$client_done->send; undef $hd;
},
on_eof => sub {
say "client_eof";
$client_done->send; undef $hd;
}
);
$hd->push_write ("1\n");
say "Sleeping..";
sleep 1;
$hd->on_drain (sub {
say "client_drain";
$client_done->send;
undef $hd; # For some reason this does not send EOF to the server
});
say "Waiting for client done..";
$client_done->recv;
say "Waiting for server done..";
$server_done->recv;
__END__
-----BEGIN RSA PRIVATE KEY-----
MIIEpAIBAAKCAQEA02VwAqlQzCrPenkxUjawHcXzJreJ9LDhX7Bkg3E/RB6Ilm4D
LBeilCmzkY7avp57+WCiVw2qkg+kH4Ef2sd+r10UCGPh/1diLehRAzp3Ho1bixyg
w+zkDm79OnN3uHxuKigkAxx3GGz9HhQA83U+RUns+39/OnFh0RY6/f5rV2ziA9jD
6HK3Mnsuxocd46YbVdiqlQK430CgiGj8dV44JG6+R6x3r5qXDbbRtGubC29kQOUq
kYslbpTo7ml8ShyqAP6qa8BpeSIaNG1CQQ/7JkAdxSWyFHqMQ0HR3BUiaEfUElZt
DFgXcCkKB5F8jx+wYoLzlPHHZaUvfP2nueYjcwIDAQABAoIBAQCtRDMuu0ByV5R/
Od5nGFP500mcrkrwuBnBqH56DdRhLPWe9sS62xRyhEuePoykOJo8qCvnVlg8J33K
JLfLRkBb09qbleKiuyjJn+Tm1IDWFd62gtxyOjQicG41/nZeS/6vpv79XdNvvcUp
ZhPxeGN1v0XyTWomqNAX5DSuAl5Q5HxkaRYNeuLZaPYkqmEVTgYqNSes/wRLKUb6
MaVrZ9AA/oHJMmmV4evf06s7l7ICjxAWeas7CI6UGkEz8ZFoVRJsLk5xtTsnZLgf
f24/pqHz1vApPs7CsJhK2HsLZcxMPD+hmTNI/Njl51WoH8zGhkv+p88vDzybpNSF
Hpkl+ZlBAoGBAOyfjVLD0OznJKSFksoCZKS4dlPHgXUb47Qb/XchIySQ/DNO6ff9
AA6r6doDFp51A8N1GRtGQN4LKujFPOdZ5ah7zbc2PfuOJGHku0Oby+ydgHJ19eW4
s3CIM20TuzLndFPrEGFgOrt+i5qKisti2OOZhjsDwfd48vsBm9U20lUpAoGBAOS1
Chm+vA7JevPzl+acbDSiyELaNRAXZ73CX4NIxJURjsgDeOurnBtLQEQyagZbNHcx
W4pc59Ql5KDLzu/Sne8oC3pxhaWeIPhc2d3cd/8UyGtQLtN2QnilwkjHgi3x1JGb
RPRsgAV6nwn10qUrze1XLkHsTCRI4QYD/k0uXcs7AoGBAMStJaFag2i2Ax4ArG7e
KFtFu4yNckwtv0kwTrBbScOWAxp+iDiJASgwunJsSLuylUs8JH8oGLi23ZaWgrXl
Yd918BpNqp1Rm2oG3aQndguZKm95Hscvi26Itv39/YYlHeq2omndu1OmrlDowM6m
vZIIRKr+x5Vz4brCro09QPxpAoGARJAdghBTEl/Gc2HgdOsJ6VGvlZMS+0r498NQ
nOvwuvuzgTTBSG1+9BPAJXGzpUosVVs/pSArA8eEXcwbsnvCixLHNiLYPQlFuw8i
5UcV1iul1b4I+63lSYPv1Z+x4BIydqBEsL3iN0JGcVb3mjqilndfT7YGMY6DnykN
UJgI2EcCgYAMfZHnD06XFM8ny+NsFILItpGqjCmAhkEPGwl1Zhy5Hx16CFDPDwGt
CmIbxNSLsDyiiK+i5tuSUFhV2Bw/iT539979INTIdNL1ughfhATR8MVNiOKCvZBa
uoEeE19szmG7Mj2eV2IDH0e8iaikjRFcfN89s39tNn1AjBNmEccUJA==
-----END RSA PRIVATE KEY-----
-----
-----BEGIN CERTIFICATE-----
MIIDHTCCAgWgAwIBAgIJAPASTbY2HCx0MA0GCSqGSIb3DQEBBQUAMBMxETAPBgNV
BAMTCEFueUV2ZW50MB4XDTEyMDQwNTA1NTk1MFoXDTM3MDQwNTA1NTk1MFowEzER
MA8GA1UEAxMIQW55RXZlbnQwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIB
AQDTZXACqVDMKs96eTFSNrAdxfMmt4n0sOFfsGSDcT9EHoiWbgMsF6KUKbORjtq+
nnv5YKJXDaqSD6QfgR/ax36vXRQIY+H/V2It6FEDOncejVuLHKDD7OQObv06c3e4
fG4qKCQDHHcYbP0eFADzdT5FSez7f386cWHRFjr9/mtXbOID2MPocrcyey7Ghx3j
phtV2KqVArjfQKCIaPx1Xjgkbr5HrHevmpcNttG0a5sLb2RA5SqRiyVulOjuaXxK
HKoA/qprwGl5Iho0bUJBD/smQB3FJbIUeoxDQdHcFSJoR9QSVm0MWBdwKQoHkXyP
H7BigvOU8cdlpS98/ae55iNzAgMBAAGjdDByMB0GA1UdDgQWBBTHphJ9Il0PtIWD
DI9aueToXo9DYzBDBgNVHSMEPDA6gBTHphJ9Il0PtIWDDI9aueToXo9DY6EXpBUw
EzERMA8GA1UEAxMIQW55RXZlbnSCCQDwEk22NhwsdDAMBgNVHRMEBTADAQH/MA0G
CSqGSIb3DQEBBQUAA4IBAQA/vY+qg2xjNeOuDySW/VOsStEwcaiAm/t24z3TYoZG
2ZzyKuvFXolhXsalCahNPcyUxZqDAekODPRaq+geFaZrOn41cq/LABTKv5Theukv
H7IruIFARBo1pTPFCKMnDqESBdHvV1xTOcKGxGH5I9iMgiUrd/NnlAaloT/cCNFI
OwhEPsF9kBsZwJBGWrjjVttU2lzMzizS7vaSIWLBuEDObWbSXiU+IdG+nODOe2Dv
W7PL43yd4fz4HQvN4IaZrtwkd7XiKodRR1gWjLjW/3y5kuXL+DA/jkTjrRgiH8K7
lVjm7gvkULRV2POQqtc2DUVXLubQmmGSjmQmxSwFX65t
-----END CERTIFICATE-----
This script hangs (Ubuntu 20.04, perl version 5.30), but if I use TLS handshake (uncomment the lines in the code with tls and tls_ctx) it works fine.
The output without TLS is:
server_listen
Sleeping..
Waiting for client done..
client_drain
server_accept
Waiting for server done..
server got line <1>
server_error <Connection timed out>
The output with TLS (after uncommenting the 4 lines starting with tls and tls_ctx) is:
server_listen
Sleeping..
Waiting for client done..
client_connect
server_accept
client_drain
Waiting for server done..
server got line <1>
server_eof
Note that on_connect is not called (client_connect is missing in the output) when not using TLS,
Even if the client is not connected when not using TLS, the server receives the data and prints server got line <1>... Very strange.
Any idea what is the problem when not using TLS?
From the looks of it, you are not reading from the socket/handle. Without reading from the socket, there is no way detect an EOF condition.
The reason why you get different behaviour with TLS is that TLS does not emulate socket semantics and AnyEvent::Handle must essentially always read, even if you don't have explicit read requests, therefore it will detect the EOF condition instantly.
You can check for this by adding an on_read handler, e.g. after or before your push_read in the server:
$hd->push_read (sub { });
With this present, it should behave more or less the same with or without TLS.
According to the documentation:
Note that, unlike requests in the read queue, an on_read callback
doesn't mean you require some data: if there is an EOF and there are
outstanding read requests then an error will be flagged. With an
on_read callback, the on_eof callback will be invoked.
This gives a clue that I need an on_read callback in order for the on_eof callback to be called. I tried to change the server to:
my $server = tcp_server(
$host,
undef, # service: must be either a service name or a numeric port number
# (or 0 or undef, in which case an ephemeral port will be used).
#
sub { # This is the accept callback..
my ($fh, $host, $port) = #_;
say "server_accept";
my $hd; $hd = AnyEvent::Handle->new(
fh => $fh,
timeout => 5,
on_error => sub {
say "server_error <$_[2]>";
$server_done->send; undef $hd;
},
on_eof => sub {
say "server_eof";
$server_done->send; undef $hd;
}
);
$hd->on_read(sub{ say "server on_read() callback"});
$hd->push_read (
line => sub {
say "server got line <$_[1]>";
}
);
}, # end of accept callback..
sub { # This is the prepare callback
say "server_listen";
$server_port->send ($_[2]);
}
);
The output is now:
server_listen
Sleeping..
Waiting for client done..
client_drain
server_accept
Waiting for server done..
server got line <1>
server_eof
so it works! (I still wonder why the client on_connect is not run, i.e. "client connect" does not show). Also notice that the on_read callback is not run since the line "server on_read() callback" is not output.
See also Why isn't on_eof called in this AnyEvent::Handle example?

Perl, IO::Socket::SSL, multi-threading

I've implemented a small webserver in Perl. It is listening with IO::Socket::INET and IO::Socket::SSL parallel.
If a connect appears at the HTTP-port I start a thread and handle the IO::Socket::INET reference.
Because of thread-limitations in Net::SSLeay (IO::Socket::SSL says in the doc is is not thread-safe below 1.43) I did NOT parallelize the SSL. I just call the handler-function in the same context.
In the parallelized case of HTTP the handler-function is the threads function.
All this is working as expected for a longer time.
I have now updated my system. Now my Net::SSLeay is 1.72 and I tried to paralellize the SSL too - the same way I do with the HTTP. But I get a segmentation fault at the first time I do a read.
use strict;
use warnings;
use IO::Handle;
use Fcntl ("F_GETFL", "F_SETFL", "O_NONBLOCK");
use Time::HiRes ("usleep");
use Socket;
use IO::Socket::SSL;
use threads;
STDOUT->autoflush ();
my $port = "4433";
my $cer = "cer.cer";
my $key = "key.key";
my $sock = IO::Socket::SSL->new (Listen => SOMAXCONN, LocalPort => $port,
Blocking => 0, Timeout => 0, ReuseAddr => 1, SSL_server => 1,
SSL_cert_file => $cer, SSL_key_file => $key) or die $#;
my $WITH_THREADS = 0; # the switch!!
for (;;)
{
eval
{
my $cl = $sock->accept ();
if ($cl)
{
print ("\nssl connect");
if ($WITH_THREADS == 0)
{
# this is no multi-threading
client ($cl);
}
else {
# with multithreading
my $th = threads->create (\&client, $cl);
$th->detach ();
}
}
}; # eval
if ($#)
{
print "ex: $#";
exit (1);
}
usleep (100000);
} # forever
sub client # worker
{
my $cl = shift;
# unblock
my $flags = fcntl ($cl, F_GETFL, 0) or die $!;
fcntl ($cl, F_SETFL, $flags | O_NONBLOCK) or die $!;
print "\n" . $cl->peerhost . "/" . $cl->peerport;
my $ret = "";
for (my $i = 0; $i < 100; $i ++)
{
$ret = $cl->read (my $recv, 5000);
# faults here if with threads!
if (defined ($ret) && length ($recv) > 0)
{
print "\nreceived $ret bytes";
}
else
{
print "\nno data";
}
usleep (200000);
}
print "\nend client";
$cl->close ();
}
I have also read some posts where they said IO::Socket::SSL is not threadsafe but I am not sure that is still the case.
Does anyone know if it is possible that way? Or maybe it is possible but I am handling it the wrong way...
Thanks,
Chris
EDIT: I use Debian 8.3 with Perl 5.20.2.
Net::SSLeay is 1.72, IO::Socket::SSL is 2.024.
OpenSSL 1.0.1k
EDIT: Changed the code-sample to fully functional little sample-program.
TL;TR:
don't duplicate an established SSL socket into another thread.
Details:
You accept the SSL socket in the master thread into $cl and then create a new thread which works on the new socket. In effect this means you have the same file descriptor (kernel), the same OpenSSL data structure (user space) but two Perl variables using this single data structure (perl threads are shared nothing - so the Perl part is duplicated).
This only causes trouble because you then implicitly close the socket in the master ($cl gets out of scope) but continue to use it in the client thread. The close in the master thread causes an SSL shutdown and then frees the underlying OpenSSL structure. Thus $cl in the client thread points to some freed memory which causes the crash. You actually get something like this (without crash) also if you use forking instead of threading, because there is still the SSL shutdown done in the master process so the peer considers the socket closed and the child will not be able to make further use of the socket.
Instead of doing the SSL accept in the master thread you should move every SSL activity into the client thread. This will be done by doing the accept on a normal socket object and then upgrading it to SSL in the client thread. This is the preferred way anyway, see Basic SSL server in the IO::Socket::SSL documentation for details.
In the end your code would be changed like this:
my $port = "4433";
my $cer = "cer.cer";
my $key = "key.key";
# don't create a SSL socket but an INET socket
my $sock = IO::Socket::IP->new (
Listen => SOMAXCONN, LocalPort => $port, Blocking => 0, ReuseAddr => 1
) or die $!;
my $WITH_THREADS = 1; # the switch!!
....
sub client # worker
{
my $cl = shift;
# upgrade INET socket to SSL
$cl = IO::Socket::SSL->start_SSL($cl,
SSL_server => 1,
SSL_cert_file => $cer,
SSL_key_file => $key
) or die $#;

Sometimes I get from socket not what I expect

I get socket handle to Httpd, the host is"127.0.0.1",the port is 80;
sub getHttpNetSock {
my $client = IO::Socket::INET->new(Proto => "tcp",
PeerAddr => $host,
Blocking => 1,
PeerPort => $port)
or return($client);
$client->autoflush(1); # so output gets there right away
return($client);
}
After this if I am able to connect I try to get info from socket.
$ch = getHttpNetSock($apachePort);
if ($ch) {
$ret = getSockVal($ch, $apachePort);
}
where getSockVal:
sub getSockVal {
my $sock = shift;
print $sock "GET http://127.0.0.1:80/test/servlet/HealthServlet\n";
my $val= <$sock>;
chomp($val);
return($val);
}
HealthServlet could return just "OK" or "TROUBLE", but in one of 100 cases I get absolutely another information. Why it could happen?
Apache and perl scripts are on the VMware virtual machine.
As you just want a GET-Request you need not resort to IO::Socket::INET and handle HTTP, let LWP do that for you.
For easy error checking the preferred way would be with LWP::UserAgent, as described here:
http://search.cpan.org/dist/libwww-perl/lib/LWP/UserAgent.pm

Check if UDP port is opened in Perl

I need to check if remote UDP port is opened. My part of code is:
sub scanUDP {
my $address = shift;
my $port = shift;
my $udpSocket = new IO::Socket::INET (
PeerAddr => $address,
PeerPort => $port,
Proto => 'udp',
) or return 0;
$udpSocket -> send ('hello', 0);
#........SOME CODE.............
return 1;
}
..SOME CODE.. should check if I received ICMP packets "Host unreached" or "Port unreached" to check if port is opened. But how can I do it?
Generally you can't. UDP does not have a connected state, so it is in no way required to send you any reply to the packet you sent. And that's even when ignoring package loss. You may get a positive reply if you sent a valid request in whatever protocol you're accessing and the remote port is open, but the absence of such a reply can not be used to make any conclusions.
If you really get an ICMP unreachable back you will receive the error with a later send call (unless you peer is localhost, than you might get it with the first one already). But there is no guarantee that you will get an ICMP unreachable back at all, because either ICMP or the UDP itself might be filtered by a firewall.
It looks like it will not report the problem on windows this way, but you can use recv there instead of send (works on UNIX too). The error code is probably something specific to windows, ECONNREFUSED works only on UNIX:
use strict;
use warnings;
use IO::Socket::INET;
my $cl = IO::Socket::INET->new(
PeerAddr => '192.168.122.42:12345', # definitly rejecting
Proto => 'udp',
);
$cl->send('foo') or die "send failed: $!"; # first send will succeed
# wait some time to receive ICMP unreachable
sleep(1);
$cl->blocking(0);
if ( ! $cl->recv( my $buf,0)) {
# will get ECONNREFUSED on UNIX, on Win the code is different
warn "error $!" if ! $!{EAGAIN};
}
This is the code that works for me:
sub scanUDP {
my $address = shift;
my $port = shift;
my $socket = new IO::Socket::INET (
PeerAddr => $address,
PeerPort => $port,
Proto => 'udp',
) or return 0;
$socket -> send('Hello',0);
my $select = new IO::Select();
$select -> add($socket);
my #socket = $select -> can_read(1);
if (#socket == 1) {
$socket -> recv(my $temp, 1, 0) or return 0;
return 1;
}
return 1;
}

Perl client/server socket

--|proxy|--|mux|--|demux|--|proxy|--
--
--
--
machineA satellite link machineB
172.16.1.224 172.16.1.218
Greetings,
I have setup as above. I'm trying to create 'mux'. Basically, it reads traffic from a proxy and splits it up for transmission over 4 wires. The 'demux' reads off 4 wires and forwards traffic on to the proxy.
I've got a basic client/server setup in Perl. But I don't know how to get traffic from the proxy into 'mux'?
Here is my code:
server.pl -- runs on 172.16.1.218
use IO::Socket;
$| = 1;
$socket = new IO::Socket::INET (
LocalHost => '172.16.1.218',
LocalPort => '5000',
Proto => 'tcp',
Listen => 5,
Reuse => 1
);
die "Coudn't open socket" unless $socket;
print "\nTCPServer Waiting for client on port 5000";
while(1)
{
$client_socket = "";
$client_socket = $socket->accept();
$peer_address = $client_socket->peerhost();
$peer_port = $client_socket->peerport();
#print "\n I got a connection from ( $peer_address , $peer_port ) ";
while (1){
$send_data = <STDIN>;
$client_socket->send($send_data);
$client_socket->recv($recieved_data,10);
print $recieved_data;#."\n";
#$client_socket->autoflush();
}
}
and:
client.pl
use IO::Socket;
$socket = new IO::Socket::INET (
PeerAddr => '172.16.1.224',
PeerPort => 5000,
Proto => 'tcp',
)
or die "Couldn't connect to Server\n";
while (1) {
$socket->recv($recv_data,10);
print $recv_data."\n";
$send_data = <STDIN>;
$socket->send($send_data);
}
I'm just a bit stuck and would appreciate any comments.
Many thanks in advance,
Your server is handling just one connection. You should use an array of connections (#socket).
You have two infinite loops nested. Since the inner one is never going to finish, you are going to attend only the first connection.
This seems a typical chat server, so i recommend you to search Google for "perl chat server". Here you have some source code that can be of help:
http://sourceforge.net/projects/perlchat/