Created a simple websocket server using perl from scratch, when pointing to it from Chrome (by using echo test), got error Error during WebSocket handshake: Incorrect 'Sec-WebSocket-Accept' header value.
Pretty sure the key returned for websocket handshake is correct. Any ideas?
use IO::Socket;
use IO::Select;
use Digest::SHA1 qw(sha1 sha1_hex sha1_base64);
$servSock = IO::Socket::INET->new( Proto => 'tcp',
LocalPort => 8080,
Reuse => 1,
Listen => 500
) || die "failed to setup outsock $#\n";
$s = IO::Select->new();
$s -> add ($servSock);
my #readySocks;
while (1) {
#readySocks = $s->can_read(5);
foreach $sock (#readySocks) {
if ($sock eq $servSock)
{
#print "inSock\n";
$clientSock = $servSock->accept();
setsockopt($clientSock, IPPROTO_TCP, TCP_NODELAY, 1);
$s->add ($clientSock);
} else
{
#print "outsock\n";
$buff = "";
$fromAddr = recv $sock, $buff, 1470, 0;
if (length($buff) <= 0)
{
$s->remove($sock);
close $sock; $numOfConns --;
next;
}
printf "recved %d bytes\n", length($buff);
if ($buff =~ /Sec-WebSocket-Key: (\S+)/) {
$str = $1;
print "key is $str|\n";
my $str = sha1_base64($str . "258EAFA5-E914-47DA-95CA-C5AB0DC85B11");
send ($sock, qq{HTTP/1.1 101 Switching Protocols\r
Connection: Upgrade\r
Upgrade: websocket\r
Sec-Websocket-Accept: $str\r
\r\n}, 0);
}
}
}
}
Note: I need to create one from scratch as part of another project.
Update
Thanks to the suggestion from #steffen-ullrich, changed it from
send ($sock, qq{HTTP/1.1 101 Switching Protocols\r
Connection: Upgrade\r
Upgrade: websocket\r
Sec-Websocket-Accept: $str\r
\r\n}, 0);
to (note there $str is now $str=)
send ($sock, qq{HTTP/1.1 101 Switching Protocols\r
Connection: Upgrade\r
Upgrade: websocket\r
Sec-Websocket-Accept: $str=\r
\r\n}, 0);
made it work.
From the documentation of sha1_bas64:
Note that the base64 encoded string returned is not padded to be a multiple of 4 bytes long. If you want interoperability with other base64 encoded sha1 digests you might want to append the redundant string "=" to the result.
And adding '=' as described is what your code is missing.
Related
I am trying to create a simple WebSocket server in perl from scratch, when I tried it in Google Chrome it gave me opcode -1, How can I fix it?
websocket.pl
#!/usr/bin/perl -w
use strict;
use IO::Socket::INET;
use Digest::SHA1 "sha1_base64";
$| = 1;
my $magic_string = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11";
# Create a server
my $socket = IO::Socket::INET->new( LocalHost => 'localhost',
LocalPort => 7777,
Proto => 'tcp',
Listen => 5,
Reuse => 1
) || die "$!";
print "Server is running on port 7777\n";
while (1) {
my $client = $socket->accept();
my $key = "";
# Get the Request
my $data = "";
while (my $line = <$client>) {
$data .= $line;
}
# Get the Sec-WebSocket-Key value
foreach my $line ( split /\n/ => $data ) {
if ( $line =~ /^Sec-WebSocket-Key: (\S+)/ ) {
$key = $1;
}
}
print "Sec-WebSocket-Key: $key\n";
# Create the Sec-WebSocket-Accept header value
my $accept = sha1_base64($key);
$accept .= "="x(4-(length($accept)%4));
print "Sec-WebSocket-Accept: $accept\n";
# Response
print $client "HTTP/1.1 101 Switching Protocols\r\n";
print $client "Upgrade: websocket\r\n";
print $client "Connection: Upgrade\r\n";
print $client "Sec-WebSocket-Accept: $accept\r\n\r\n";
shutdown($client, 1);
}
$socket->close();
I am pretty sure that the key returned to website is correct, so where is the problem? What went wrong?
ws.js
var ws = new WebSocket("ws://localhost:7777/");
ws.onopen = function() {
alert("connected!");
ws.send( 'Hello server' );
};
ws.onclose = function() {
alert( 'Connection is closed... ');
};
Web Browser network traffic
Edit
Stefan Becker: Yea, I know, but in this case I was sure that the request is under 1024 bytes, I've fixed it, thanks.
(Opcode -1) is a generic error. In your case it is a bad Sec-WebSocket-Accept header. You forgot to use $magic_string:
my $accept = sha1_base64($key.$magic_string);
Also while (my $line = <$client>) { will probably run forever. You need to check for an empty line.
I am making socket programming for simple communication now.
I have noticed that the server is not the one I created and it works fine (given the experimental client)
In my code, recv works fine, but send does not work. Is there anything wrong with my code?
my $socket = new IO::Socket::INET (
#PeerHost => '127.0.0.1',
PeerHost => '192.168.0.100',
PeerPort => '8472',
Proto => 'tcp',
);
die "cannot connect to the server $!\n" unless $socket;
print "connected to the server\n";
while (1) {
my $response = "";
$socket->recv($response, 1024);
if ($response) {
my #test = split(//,$response);
my ($length,$data) = unpack("N A*",$response);
%json = json_decode($data,$length);
switch ($json{'type'}) {
case 1 { print "Game Start\n";}
#case 2 { my $tmp = &my_turn(%json);} #my_turn func is return "{'type': 0, 'point': [5, 4]}", but fail!
#case 2 { $socket->send("{'type': 0, 'point': [5, 4]}");} # fail!
case 2 { print $socket "{'type': 0, 'point': [5, 4]}"; print "ok\n";} # print is executed. However, the server does not receive packets
#case 2 { $socket->send("{'type': 0, 'point': [5, 4]}");} #fail...
case 3 { print "ACCEPT\n";}
case 5 { print "NOPOINT\n";}
case 6 { print "GAMEOVER\n";}
case 7 { print "ERROR\n";}
else {print "ERROR type : $json{'type'}\n"}
}
}
}
The server works fine. I checked with the example source (python code) given with the server. What am I missing?
You can't assume the recv (or read) will return the entire response. You need to call it repeatedly.
You can't assume the recv (or read) will just the response. You need to limit the size of the read of buffer the excess.
decode_json returns a reference (not a list of key-value pairs you can assign to a hash).
You might also have to handle encoding of the JSON string. The example below assumes UTF-8 encoding.
JSON response to the server (case 2 in the original code) needs to include length too.
The following code should be used instead:
#!/usr/bin/perl
use strict;
use warnings;
use JSON;
use IO::Socket;
my $socket = IO::Socket::INET->new(
PeerHost => '127.0.0.1',
PeerPort => '22',
Proto => 'tcp',
) or
die "cannot connect to the server $!\n";
print "connected to the server\n";
sub read_bytes($$) {
my($socket, $length) = #_;
my $result = '';
print "ATTEMPT TO READ ${length}\n";
while ($length > 0) {
my $received = $socket->read($result, $length, length($result));
die "socket error: $!\n" unless defined($received);
die "unexpected EOF\n" unless $received;
$length -= $received;
}
print "READ '${result}'\n";
return($result);
}
while (1) {
my $length = unpack("N", read_bytes($socket, 4));
my $json = read_bytes($socket, $length);
my $data = JSON->new->utf8->decode($json);
print $data->{type}, "\n";
if ($data->{type} == 2) {
my $response = {
type => 0,
point => [5, 4],
};
my $resp_json = JSON->new->utf8->encode($response);
print "JSON: ${resp_json}\n";
my $packet = pack('NA*', length($resp_json), $resp_json);
print "PACKET: ", unpack('H*', $packet), "\n";
$socket->write($packet);
}
}
As I don't have access to your server I used sshd on my local machine, which of course does not send me a JSON. But it shows that reading works :-)
$ perl dummy.pl
connected to the server
ATTEMPT TO READ 4
READ 'SSH-'
ATTEMPT TO READ 1397966893
^C
Output for an example response to the server would be:
JSON: {"type":0,"point":[5,4]}
PACKET: 000000187b2274797065223a302c22706f696e74223a5b352c345d7d
I am trying to figure out a proper way to parse a stream of data using perl.
I have read through many of the examples, documentations and questions, but could not find how I could basically cut a "package" from the stream of data and process it.
This is the situation:
- stream of data coming from a certain IP to an IP and port
- stream contains some gibberish and then something between and with the data in there being semicolon seperated
My attempts so far is to have a Socket listening on the port and process the $data var:
#!/usr/bin/perl
use IO::Socket::INET;
# auto-flush on socket
$| = 1;
# creating a listening socket
my $socket = new IO::Socket::INET (
LocalHost => '127.0.0.1',
LocalPort => '7070',
Proto => 'tcp',
Listen => 5,
Reuse => 1
);
die "cannot create socket $!\n" unless $socket;
print "server waiting for client connection on port 7070 \n";
while(1)
{
# waiting for a new client connection
my $client_socket = $socket->accept();
# get information about a newly connected client
my $client_address = $client_socket->peerhost();
my $client_port = $client_socket->peerport();
print "connection from $client_address:$client_port\n";
# read up to 1024 characters from the connected client
my $data = "";
$client_socket->recv($data, 1024);
print "received data: $data\n";
#data_array = split(/;/,$data);
foreach (#data_array) {
print "$_\n";
}
# write response data to the connected client
$data = "ok";
$client_socket->send($data);
# notify client that response has been sent
shutdown($client_socket, 1);
}
$socket->close();
This works but as far as I understand this will put the whole stream in up to the size and then process that.
My question:
How can I identify the part I need (start-end), process that and then go on to the next?
I've never understood why people use recv to read from a stream socket.
Normally, the reading loop looks something like the following:
my $buf = '';
while (1) {
my $rv = sysread($socket, $buf, 64*1024, length($buf));
if (!defined($rv)) {
die("Can't read from socket: $!\n");
}
if (!$rv) {
die("Can't read from socket: Premature EOF\n") if length($buf);
last;
}
while (my $msg = defined(check_for_full_message_and_extract_it_from_buf($buf))) {
process_msg($msg);
}
}
(Keep in mind that sysread returns as soon as there is some data, even if there's less data than requested.)
For example, the inner loop for sentinel-terminated data would look like the following:
while ($buf =~ s/^(.*)\n//) {
process_msg("$1");
}
For example, the inner loop for length-prefixed blocks would look like the following:
while (1) {
last if length($buf) < 4;
my $len = unpack('N', $buf);
last if length($buf) < 4+$len;
substr($buf, 0, 4, '');
my $msg = substr($buf, 0, $len, '');
process_msg($msg);
}
If you're particular case, you'd remove any data from the start $buf that you want to ignore until you get to the part in which you're interested, then you'd start extracting the items in which you are interested. This is vague, but I only have a vague description of the protocol with which to work.
I solved this by using the original code and adding :
if ( $data=~/<START>>/) {
print "\nFound start\n";
$message.=$data;
while ($message !~/END/){
$client_socket->recv($data, $message_length);
$message.=$data;
print "\nStill reading\n";
};
print "\nFound end\n"; # but may contain (part of) next START
}
I still need to implement the part where I check if the chunk read has part of the next message, but I'll figure that out.
Thank you for the help!
I want to set timeout in my recv function in this specific code below, because sometimes my script stuck forever. I am new in socket programming so i would really appreciate any help. Thanks in advance.
use IO::Socket::INET;
use IO::Select;
use LWP::UserAgent;
use JSON::XS 'decode_json';
use Data::Dumper;
use DBI();
sub dbconn {
my $db_conf = shift;
my $dbh = DBI->connect("DBI:Pg:dbname=somedatabase;host=somehost", "postgres", "",
{pg_server_prepare =>
0,AutoCommit => 1,RaiseError=>1});
$dbh->do("SET CLIENT_ENCODING TO 'UTF-8';");
return $dbh;
}
# auto-flush on socket
$| = 1;
# creating a listening socket
my $socket = new IO::Socket::INET (
LocalHost => '0.0.0.0',
LocalPort => '5000',
Proto => 'tcp',
Listen => 5,
Reuse => 1
);
die "cannot create socket $!\n" unless $socket;
$sel = IO::Select->new( $socket );
print "Server waiting for client connection on port 5000...\n";
my $command = 1;
my $watchTracker = "*HQ,";
my $tl206 = ",LAT:";
my $watchConnectedCheck = ",A,";
my $gpsType;
my $circleString = ",LINK,";
my $dataToSend;
my $new;
my $dbh = dbconn();
while(#ready = $sel->can_read) {
foreach $fh (#ready) {
if($fh == $socket) {
# Create a new socket
$new = $socket->accept;
$new->recv($dataReceived, 1024);
$new->recv($dataReceived, 1024);
# get information about a newly connected client
my $client_address = $new->peerhost();
my $client_port = $new->peerport();
print "===============================================\n";
print "===============================================\n\n";
print "Connection from $client_address:$client_port\n";
print "General data received: $dataReceived\n\n";
#MORE LINES...
}
else {
# Process socket
# Maybe we have finished with the socket
$sel->remove($fh);
$fh->close;
}
}
}
$dbh->disconnect();
Perhaps I am misunderstanding the question, but have you tried setting a timeout in the socket with "Timeout"?
See IO::Socket::INET.
EDIT: I did not catch the 'recv' bit. You have to use setsockopt, which is not wholly portable, so the final answer is somewhat dependent on your platform. Here are some posts that may help:
How do I set `SO_RCVTIMEO` on a socket in Perl?
http://www.perlmonks.org/?node_id=761935
E.g.,
$socket->setsockopt(SOL_SOCKET, SO_RCVTIMEO, pack('l!l!', 30, 0))
or die "setsockopt: $!";
I am writing a Perl script that acts as a simple web server that serves audio files over HTML5. I have succeeded in getting it to show a page to a web browser with an HTML5 audio element. It continues to listen to the socket for when the browser asks for an audio file via a GET request; hh.ogg in this example and tries to respond with the ogg inside the message body. It works over port 8888.
#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket;
my $port = 8888;
my $server = new IO::Socket::INET( Proto => 'tcp',
LocalPort => $port,
Listen => SOMAXCONN,
ReuseAddr => 1)
or die "Unable to create server socket";
# Server loop
while(my $client = $server->accept())
{
my $client_info;
my $faviconRequest = 0;
while(<$client>)
{
last if /^\r\n$/;
$faviconRequest = 1 if ($_ =~ m/favicon/is);
print "\n$_" if ($_ =~ m/GET/is);
$client_info .= $_;
}
if ($faviconRequest == 1)
{
#Ignore favicon requests for now
print "Favicon request, ignoring and closing client";
close($client);
}
incoming($client, $client_info) if ($faviconRequest == 0);
}
sub incoming
{
print "\n=== Incoming Request:\n";
my $client = shift;
print $client &buildResponse($client, shift);
print "Closing \$client";
close($client);
}
sub buildResponse
{
my $client = shift;
my $client_info = shift;
my $re1='.*?';
my $re2='(hh\\.ogg)';
my $re=$re1.$re2;
print "client info is $client_info";
# Send the file over socket if it's the ogg the browser wants.
return sendFile($client) if ($client_info =~ m/$re/is);
my $r = "HTTP/1.0 200 OK\r\nContent-type: text/html\r\n\r\n
<html>
<head>
<title>Hello!</title>
</head>
<body>
Hello World.
<audio src=\"hh.ogg\" controls=\"controls\" preload=\"none\"></audio>
</body>
</html>";
return $r;
}
sub sendFile
{
print "\n>>>>>>>>>>>>>>>>>>>>>>> sendFile";
my $client = shift;
open my $fh, '<' , 'hh.ogg';
my $size = -s $fh;
print "\nsize: $size";
print $client "Allow: GET\015\012";
print $client "Accept-Ranges: none\015\012";
print $client "Content-Type: \"audio/ogg\"\015\012";
print $client "Content-Length: $size\015\012";
print "\nsent headers before sending file";
############################################
#Take the filehandle and send it over the socket.
my $scalar = do {local $/; <$fh>};
my $offset = 0;
while(1)
{
print "\nsyswriting to socket. Offset: $offset";
$offset += syswrite($client, $scalar, $size, $offset);
last if ($offset >= $size);
}
print "Finished writing to socket.";
close $fh;
return "";
}
The sendFile subroutine is called when the GET request matches a regex for hh.ogg.
I send a few headers in the response before writing the ogg to the socket before closing.
This code works exactly as I'd expect in Firefox. When I press play the script receives a GET from Firefox asking for the ogg, I send it over and Firefox plays the track.
My problem is the script crashes in Google Chrome. Chrome's developer tools just says it cannot retrieve hh.ogg. When I visit 127.0.0.1:8888 in my browser while the script is running I can download hh.ogg. I have noticed that Chrome will make multiple GET requests for hh.ogg whereas Firefox just makes one. I've read that it may do this for caching reasons? This could be a reason as to why the script crashes.
I have
print $client "Accept-Ranges: none\015\012";
to try and stop this behaviour but it didn't work.
I'm not sure of exactly what headers to respond to Chrome to let it receive the file within one HTTP response. When the script crashes I also occasionally get this message printed out from Perl; otherwise there are no other errors. It will quit somewhere inside the while loop where I syswrite() to the socket.
Use of uninitialized value in addition (+) at ./test.pl line 91, <$fh> line 1.
Which is referring to this line.
$offset += syswrite($client, $scalar, $size, $offset);
I don't know why there would be any uninitialized values.
Would anyone have any ideas why this could be happening? If at all possible I'd like to accomplish this without requiring additional modules from CPAN.
Use a real web server instead that is already working and thorougly debugged instead of messing with sockets yourself. The Web is always more complicated than you think. Run the following app with plackup --port=8888.
use HTTP::Status qw(HTTP_OK);
use Path::Class qw(file);
use Plack::Request qw();
use Router::Resource qw(router resource GET);
my $app = sub {
my ($env) = #_;
my $req = Plack::Request->new($env);
my $router = router {
resource '/' => sub {
GET {
return $req->new_response(
HTTP_OK,
[Content_Type => 'application/xhtml+xml;charset=UTF-8'],
[ '… HTML …' ] # array of strings or just one big string
)->finalize;
};
};
resource '/hh.ogg' => sub {
GET {
return $req->new_response(
HTTP_OK,
[Content_Type => 'audio/vorbis'],
file(qw(path to hh.ogg))->resolve->openr # file handle
)->finalize;
};
};
};
$router->dispatch($env);
};
Your error says Use of uninitialized value in addition which means it is not inside the syswrite, but in the += operation. syswrite() returns undef if there is an error. Which seems consistent with your overall error with Chrome. The $! variable contains some info about the writing error.