I am developing a server as a kind of gateway/router that opens a dynamic number of inbound, non-blocking tcp ports/sockets. The number of sockets is dynamically read from a config file, therefore the sockets are stored in an array.
I re-used older code with only one inbound socket, that used IO::Select.
My new code creates an array of in_lists (IO::Select) with the corresponding socket.
My current problem is:
After opening all sockets, only the last socket is connectible - all sockets before refuse the connection.
## Listen to a guest TCP connection
our #tcpin_sock;
our #in_list;
foreach my $host (#config::hostkeys) {
# Create In-Port
$tcpin_sock[$host] = create_in_socket($tcpin_sock[$host], $inport, 'tcp');
$in_list[$host] = IO::Select->new($tcpin_sock[$host]);
}
while (1) {
# Listen to incoming TCP guests
foreach my $host (#config::hostkeys) {
#print STDERR "Listen for guests for $host...\n";
if (my #in_ready = $in_list[$host]->can_read(0.2)) {
foreach my $guest (#in_ready) {
if($guest == $tcpin_sock[$host]) {
my $new = $tcpin_sock[$host]->accept or die "ERROR: It seems that this port is already occupied: $! ($#)\n";
my $newremote = $new->peerhost();
print STDERR "New guest connection accepted from $newremote.\n";
$in_list[$host]->add($new);
} else {
$guest->recv(my $guest_line, 1024);
print STDERR $guest_line;
}
}
}
}
}
I think that my handling of IO::Select is wrong, and that it does not support multiple lists?
What I need would be the handling of multiple sockets, but on every client connection, inside the client processing, I need to know to what port/socket the connection was created to.
Has someone an idea how to implement the IO::Select for that case?
Thank you!
Christian
Related
I have a simple server socket
my $server = IO::Socket::INET->new(
LocalPort => $config{'local-port'},
Reuse => 1,
Listen => 10,
Timeout => 1,
Blocking => 1
) or croak "Couln't start server: $!\n";
I want to keep doing some routine while client is connected
while (1) {
my $client = $server->accept;
next unless $client;
say "new connection";
# this loop never ends
while ( $client->connected ) {
# do_work();
}
say "connection closed";
}
But $socket->connected always return true (or seemingly until tcp keepalive is not sent).
Is there a way to check if client is still connected (for example if it didn't send anything in 10 seconds it can be considered disconnected)?
Is there a way to check if client is still connected (for example if it didn't send anything in 10 seconds it can be considered disconnected)?
"Disconnected" in terms of TCP means that an explicit TCP shutdown was done. No data for 10 seconds is different from this - it is an expectation that the application will send data every 10 seconds and if this does not happen something is wrong, like crash of peer or loss of connectivity.
To detect any of this it is necessary to actually attempt to read from the socket. In case of an explicit TCP disconnect the read will return that 0 bytes are read w/o any failure.
This is different from having the connection open but no data available - here the read will hang on a blocking socket so select or similar should be used to check first if there would be something to read. Alternatively use a non-blocking socket in which case the read would fail with EWOULDBLOCK (or EAGAIN, which is the same on most OS).
If actually reading the data does not fit in the way the program is designed, one could instead also use a combination of select (check that something is read) and MSG_PEEK to just check the state of the socket buffer and the underlying connection, i.e. something like this:
vec(my $rin = '', fileno($socket), 1) = 1;
my $n = select($rin, undef, undef, undef, 0);
if ($n<0) {
# something wrong, socket likely already explicitly locally closed
} elsif ($n == 0) {
# read would block, i.e. no explicit disconnect and no data to read
} else {
$n = recv($socket, my $buf, 1, MSG_PEEK);
if ($n>0) {
# data available in socket buffer
} elsif ($n==0) {
# no data available and no errno -> socket closed by peer
} else {
# socket broken, for example keep alive timer failed
}
}
I have a backendserver and different clients who provide different services.
In a thread I wait for incoming TCP connections. Then they should send am message with what type they are, like a robot or a frontend.
On the backend I now wait for the connections and check what type they are, and depending on that I want it to be copied into for example a $frontendSocket:
$requestConnectionSocket = new IO::Socket::INET(...);
$frontendSocket;
sub waitForConnection {
threads->create(sub {
while(1){
$newSocket = $requestConnectionSocket->accept();
$newSocket->recv($message, 1024);
if ($message eq "Frontend")
{
$frontendSocket = $newSocket;
$frontendSocket->send("hello\n");
}
if ($message eq "Roboter")
{$robotSocket = $newSocket;}
if ($message eq "Sensor")
{$sensorSocket = $newSocket;}
}
});
}
When I runt the script, in this thread I can send the message "hello". But when I want to use the socket outside I am not able to use $frontendSocket.
I hope you understand my problem.
You have multiple threads accessing the same frontendSocket. This is doomed to fail. What is going to happen when one thread receives a new message (and updates the socket with it), but another thread is still working with the previous socket? Can't do this.
If you're using IO::Socket wouldn't you rather use the accept method from the package like:
my $newSocket = $requestConnectionSocket->accept();
This returns an object and I see no issues assigning that object to a differently named scalar reference.
Okay you updated your question with code like the above, now:
It looks like you're trying to share state in threads, have you planned your thread safety?
# http://perldoc.perl.org/threads/shared.html
use threads;
use threads::shared;
...
my ($requestConnectionSocket, $frontendSocket, $robotSocket, $sensorSocket) :shared;
sub waitForConnection {
threads->create(sub {
while(1){
my $newSocket;
{
lock($requestConnectionSocket);
$newSocket = $requestConnectionSocket->accept();
}
$newSocket->recv($message, 1024);
if ($message eq "Frontend")
{
lock($frontendSocket);
$frontendSocket = $newSocket;
$frontendSocket->send("hello\n");
}
if ($message eq "Roboter")
{lock($robotSocket); $robotSocket = $newSocket;}
if ($message eq "Sensor")
{lock($sensorSocket); $sensorSocket = $newSocket;}
}
});
}
... meanwhile, in another context ...
# I have front end work to do now, figure out if I need to lock or wait and on what.
I need to make blocking socket read end by timeout. I read this question, I learned that IO::Socket::INET doesn't pay attention to Timeout option and learned about solution using eval/alarm. But I'm working on Windows and alarm doesn't work properly. Is there any other solution?
Prior to reading from the socket, use the 4-argument version of select, with the desired timeout, to test whether any data is available on the socket to be read.
Also see the IO::Select module, and specifically the IO::Select::can_read($timeout) method to test if a socket read will block or not.
Example:
$read_timeout = 5.0; # seconds
$socket = IO::Socket->new( ... ); # socket to read from
$selector = IO::Select->new;
$selector->add( $socket );
...
#ready = $selector->can_read( $read_timeout );
if (#ready > 0) {
$socket->read( $buffer, 128 ); # copy 128 bytes into $buffer
} else {
warn "data not available on socket now";
}
I am trying to send and receive requests to the same socket in the following fashion.
open socket
send LOGINPDU,
recv response from server and if ok send TRANSPDU
recv response from server
send LOGOUTPDU.
Sample of what am trying to do below:
#1
my $sock = IO::Socket::INET->new( Proto=> "tcp", PeerAddr => "$IP",
PeerPort => "$port") ||
die "Could not connect to host => $IP:$port \n";
#2
print $sock $LOGINPDU."\n";
#3
while($ans=<$sock>) {
$ans1.=$ans;
}
$sock->flush();
if($ans1) {
print $sock $transPDU."\n";
#4
while($tns=<$sock>) {
$tns.=$tns;
}
}
#5
$sock->close();
The problem is that I am only receiving response for the first request.
I would guess that the problem is that your script stays in the first while loop, which waits for the response lines after LOGINPDU is sent to the server (step 2 -> 3)). This is because readline (< >) is blocking and the server did not send an EOF, which is (with your) code the only option to get out of the loop, but as a side-effect it would also close the connection.
So, if the server's answer is (only) one line you can try something like this:
$ans1=<$sock>;
$sock->flush();
if($ans1) {
...
}
Hope that helped a bit.
I am trying to make my own Jabber bot but i have run into a little trouble. I have gotten my bot to respond to messages, however, if I try to change the bot's presence then it seems as though all of the messages you send to the bot get delayed.
What I mean is when I run the script I change the presence so I can see that it is online. Then when I send it a message it takes three before the callback subroutine I have set up for messages gets called. After the thirrd message is sent and the chat subroutine is called it still process the first message I sent.
This really doesn't pose too much of a problem except that I have it set up to log out when I send the message "logout" and it has to be followed by two more messages in order to log out. I am not sure what it is that I have to do to fix this but i think it has something to do with iq packets because I have an iq callback set as well and it gets called two times after setting the presence.
Here is my source code:
#!/usr/bin/perl
use strict;
use warnings;
#Libraries
use Net::Jabber;
use DBI;
use DBD::mysql;
#--------------- Config Vars -----------------
# Jabber Client
my $jbrHostname = "DOMAINNAME";
my $jbrUserName = "USERNAME";
my $jbrPassword = "PASSWORD";
my $jbrResource = "RESOURCE";
my $jbrBoss = new Net::Jabber::JID();
$jbrBoss->SetJID(userid=>"USERNAME",server=>$jbrHostname);
# MySQL
my $dbHostname = "DOMAINNAME";
my $dbName = "DATABASENAME";
my $dbUserName = "USERNAME";
my $dbPassword = "PASSWORD";
#--------------- End Config -----------------
# connect to the db
my $dbh = DBI->connect("DBI:mysql:database=$dbName;host=$dbHostname",$dbUserName, $dbPassword, {RaiseError => 1}) or die "Couldn't connect to the database: $!\n";
# create a new jabber client and connect to server
my $jabberBot = Net::Jabber::Client->new();
my $status = $jabberBot->Connect(hostname=>$jbrHostname) or die "Cannot connect ($!)\n";
my #results = $jabberBot->AuthSend(username=>$jbrUserName,password=>$jbrPassword,resource=>$jbrResource);
if($results[0] ne "ok")
{
die "Jabber auth error #results\n";
}
# set jabber bot callbacks
$jabberBot->SetMessageCallBacks(chat=>\&chat);
$jabberBot->SetPresenceCallBacks(available=>\&welcome);
$jabberBot->SetCallBacks(iq=>\&gotIQ);
$jabberBot->PresenceSend(type=>"available");
$jabberBot->Process(1);
sub welcome
{
$jabberBot->MessageSend(to=>$jbrBoss->GetJID(),subject=>"",body=>"Hello There!",type=>"chat",priority=>10);
&keepItGoing;
}
$jabberBot->MessageSend(to=>$jbrBoss->GetJID(),subject=>"",body=>"Hello There! Global...",type=>"chat",priority=>10);
#$jabberBot->Process(5);
&keepItGoing;
sub chat
{
print "Chat Called!\n";
my ($sessionID,$msg) = #_;
$jabberBot->MessageSend(to=>$msg->GetFrom(),subject=>"",body=>"Chatting!",type=>"chat",priority=>10);
if($msg->GetBody() ne 'logout')
{
print $msg->GetBody()."\n";
&keepItGoing;
}
else
{
&killBot($msg);
}
}
sub gotIQ
{
print $_[1]->GetID()."\n";
&chat;
}
sub keepItGoing
{
print "Movin' the chains!\n";
my $proc = $jabberBot->Process(1);
while(defined($proc) && $proc != 1)
{
$proc = $jabberBot->Process(1);
}
}
sub killBot
{
$jabberBot->MessageSend(to=>$_[0]->GetFrom(),subject=>"",body=>"Logging Out!",type=>"chat",priority=>10);
$jabberBot->Process(1);
$jabberBot->Disconnect();
exit;
}
Thanks for your help!
You've got resource starvation because of your keepItGoing routine. In general, trying to use XMPP synchronously like this is not going to work. I suggest getting your callbacks set up, then just calling Process() in one loop.
The docs for Process() say:
Process(integer) - takes the timeout period as an argument. If no
timeout is listed then the function blocks until
a packet is received. Otherwise it waits that
number of seconds and then exits so your program
can continue doing useful things. NOTE: This is
important for GUIs. You need to leave time to
process GUI commands even if you are waiting for
packets. The following are the possible return
values, and what they mean:
1 - Status ok, data received.
0 - Status ok, no data received.
undef - Status not ok, stop processing.
IMPORTANT: You need to check the output of every
Process. If you get an undef then the connection
died and you should behave accordingly.
Each time you call Process(), 0 or more of your callbacks will fire. You never know which, since it depends on server timing. If you want for Process() to return before sending something, you're almost always thinking synchronously, rather than asych, which kills you in XMPP.
In your case, if you remove the call to keepItGoing from chat(), I bet things will work more like you expect.
Replace the line:
$jabberBot->Process(1);
with these:
while (defined($jabberBot->Process(1))) {
# Do stuff here
}