Small issue with IO::Socket server and POST data - perl

For some reasons I can only use IO::Socket to build my small http server (not the other modules dedicated to that).
EDIT1: I edited my question, I want to know what I can put instead of the commented line "#last ..."
Here is my script:
use strict;
use IO::Socket;
my $server = IO::Socket::INET->new(LocalPort => 6800,
Type => SOCK_STREAM,
Reuse => 1,
Listen => 10) or die "$#\n";
my $client ;
while ( $client = $server->accept()) {
my $client_info;
while(<$client>) {
#last if /^\r\n$/;
print "received: '" . $_ . "'\n";
$client_info .= $_;
}
print $client "HTTP/1.0 200 OK\r\n";
print $client "Content-type: text/html\r\n\r\n";
print $client '<H1>Hello World(!), from a perl web server</H1>';
print $client '<br><br>you sent:<br><pre>' . $client_info . '</pre>';
close($client);
}
Now, when I send a POST request, it (the script) doesn't take into account the last line (the POST data):
wget -qO- --post-data='hello=ok' http://127.0.0.1:6800
<H1>Hello World(!), from a perl web server</H1><br><br>you sent:<br><pre>POST / HTTP/1.1
User-Agent: Wget/1.14 (linux-gnu)
Accept: */*
Host: 127.0.0.1:6800
Connection: Keep-Alive
Content-Type: application/x-www-form-urlencoded
Content-Length: 8
</pre>
The script output is:
perl server.pl
received: 'POST / HTTP/1.1
'
received: 'User-Agent: Wget/1.14 (linux-gnu)
'
received: 'Accept: */*
'
received: 'Host: 127.0.0.1:6800
'
received: 'Connection: Keep-Alive
'
received: 'Content-Type: application/x-www-form-urlencoded
'
received: 'Content-Length: 8
'

This is to be expected. A POST request looks like
POST / HTTP/1.1
Header: Value
Data=Value
You terminate processing after the end of the header, but the data is in the body!
If you really want to write your own HTTP server, then you should extract the HTTP method from the header. If it is POST, you can look at the value from the Content-length header, and read that number of bytes:
read $client, my $post_data, $content_length;
WRT the updated question:
If you want to build a production HTTP server, you are going to have a bad time. This stuff is difficult. Please read through perlipc which covers the topic of TCP servers. You can then implement a subset of HTTP on top of this.
Also read through the modules on CPAN that implement servers. Even if you cannot compile modules on your system, you may be able to use pure-Perl modules, or may find parts of code that you can reuse. Large parts of CPAN can be used under a GPL license.
If you want to do this, do it right. Write yourself a subroutine that parses a HTTP request. Here is a sketch that doesn't handle encoded fields etc.:
use strict; use warnings; use autodie;
BEGIN { die "Untested code" }
package Local::HTTP::Request {
sub new {
my ($class, $method, $path, $version, $header_fields, $content) = #_;
...;
}
...; # accessors
sub new_from_fh {
my ($class, $fh) = #_;
local $/ = "\015\102"; # CRLF line endings
chomp(my $first_line = <$fh>);
my ($method, $path, $version) = ...; # parse the $first_line
# this cute little sub parses a single field incl. continuation
# and returns the next line as well.
my $parse_a_field = sub {
chomp(my $line = shift);
my ($name, $value) = split /:\s+/, $line, 2;
while(defined(my $nextline = <$fh>)) {
# handle line continuation
if ($nextline =~ s/^[ \t]//) {
chomp $nextline;
$value .= $nextline;
} else {
return $name, $value, $nextline;
}
}
};
my %fields;
my $line = <$fh>;
until ($line eq $/) {
(my $name, my $value, $line) = $parse_a_field->($line);
$fields{lc $name} = $value;
}
read $fh, my $content, $fields{"content-length"} // 0;
return $class->new( ... );
}
}
Then in your accept loop:
my $request = Local::HTTP::Request->new_from_fh($client);
print $client "HTTP/1.0 200 OK", "\015\012";
print $client "Content-type: text/plain", "\015\012";
print $client "\015\012";
print $client "Request body:\n";
print $client $request->content;

Related

WebSocket server from scratch showing opcode -1

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.

Printing Zebra Labels using Perl CGI

I am having issues printing Zebra labels from a Perl CGI, where it works on one server but not another. Also, if I run the program from the command line it works on either server. The servers are IIS 7 (don't laugh it's what I'm stuck using).
Here is the code:
use strict;
use Socket;
use CGI qw(:cgi-lib);
use CGI::Carp qw ( fatalsToBrowser );
my %formdata = Vars;
print "Content-type: text/html\r\n\r\n";
# to test running from the command line, hardcode the paramters normally passed from the web interface
# comment these out when running CGI
$formdata{printer} = "zebraprinter.mycompany.com";
$formdata{serials} = "TR16170003|Gerry's Product TR|This is a generic product where all serial numbers start with the letters TR|T~";
# initialize server and port
my $port = 9100;
# create the socket, connect to the port
socket(SOCKET,PF_INET,SOCK_STREAM,(getprotobyname('tcp'))[2]) or myExit("Can't create a socket $!\n");
connect( SOCKET, pack_sockaddr_in($port, inet_aton($formdata{printer}))) or myExit("Can't connect to port $port! \n");
foreach my $serial(split("~", $formdata{serials}))
{
my #ar = split(/\|/, $serial);
my $line;
if ($formdata{printer} =~ /label2/) # small labels
{
$line = "^XA^PRA,A,A^LH5,5^FO10,10^BCN,50,N,N,N,D^FD$ar[0]^FS";
$line .= "^FO300,10^AD,15,12^FDSerial Number:^FS";
$line .= "^FO300,30^AD,15,12^FD$ar[0]^FS^XZ";
}
else # large labels
{
$line = "^XA^PRA,A,A^LH20,20";
$line .= "^FO20,40^FWN^AT,60,10^FD Serial Number: $ar[0]^FS";
$line .= "^FO20,120^FWN^AT,60,10^FD $ar[1]^FS";
# need to hard break and limit long lines
if (length($ar[2]) > 60)
{
my $part = substr($ar[2],0,60);
$line .= "^FO20,200^FWN^AT,60,10^FD Description: $part^FS";
$part = substr($ar[2],61,74);
$line .= "^FO20,260^FWN^AT,60,10^FD$part^FS";
$line .= "^FO50,340^B3N,N,100,Y,N^FD$ar[0]^FS";
}
else
{
$line .= "^FO20,200^FWN^AT,60,10^FD Description: $ar[2]^FS";
$line .= "^FO50,280^B3N,N,100,Y,N^FD$ar[0]^FS";
}
$line .= "^XZ";
# example formatted label
#$line = qq~^XA^PRA,A,A^LH20,20^FO20,40^FWN^AT,60,10^FD Serial Number: $ar[0]^FS^FO20,120^FWN^AT,60,10^FD Product: $ar[1]^FS^FO20,200^FWN^AT,60,10^FD Description: $ar[2]^FS^FO50,280^B3N,N,100,Y,N^FD$ar[0]^FS^XZ~;
}
print SOCKET $line;
}
close SOCKET;
myExit("Labels Printed.");
sub myExit
{
my $msg = shift;
print "<script>alert('$msg')</script>";
exit;
}
I'm guessing it has something to do with opening sockets in a CGI but I don't have a whole lot of experience with that.
Thanks in advance
It turns out that our Zebra printer is sending a response after printing labels and waiting to verify it was delivered, which locked it up. The solution that is working so far is to get the response but also set a short timeout on the socket just in case. Also went up the food chain and used IO::Socket instead of the old Socket library:
use strict;
use IO::Socket;
use CGI qw(:cgi-lib);
use CGI::Carp qw ( fatalsToBrowser );
my %formdata = Vars;
print "Content-type: text/html\r\n\r\n";
# to test running from the command line, hardcode the paramters normally passed from the web interface
# comment these out when running CGI
$formdata{printer} = "zebralabel1.mycompany.com";
$formdata{serials} = "TR16170003|Gerry's Product TR|This is a generic product where all serial numbers start with the letters TR|T~";
# create the socket, connect to the port
my $remote = IO::Socket::INET->new(
Proto => 'tcp',
PeerAddr=> "$formdata{printer}",
PeerPort=> "9100",
ReuseAddr=> 0,
Timeout => 2,
) or myExit("Cannot connect to printer: $!");
$remote->autoflush(1); # Send immediately
my ($serial, $product, $desc) = split(/\|/, $formdata{serials});
# example formatted label
my $line = qq~^XA^PRA,A,A^LH20,20^FO20,40^FWN^AT,60,10^FD Serial Number: $serial^FS^FO20,120^FWN^AT,60,10^FD Product: $product^FS^FO20,200^FWN^AT,60,10^FD Description: $desc^FS^FO50,280^B3N,N,100,Y,N^FD$serial^FS^XZ~;
print $remote $line;
my $dontCare = <remote>;
close $remote;
myExit("Labels Printed.");
sub myExit
{
my $msg = shift;
print "<script>alert('$msg')</script>";
exit;
}

How do I get a list of all todo items in a CalDAV calendar from Perl?

I've got a CalDAV calendar, and want to pull out all todo items from it, then delete them.
Either the Cal::DAV or HTTP::DAV module is possibly the way to go, but it's not at all clear how to do what I want, without learning a lot about CalDAV, which I'm hoping to avoid :-)
Here's an example using raw sockets to connect and send the request manually - I found using a library like lwp, or http just gets cumbersome with the need for overriding the headers.
Referenced the request format from http://sabre.io/dav/building-a-caldav-client/
#!/usr/bin/env perl
use strict 'vars';
use warnings;
use Socket;
# initialize host and port
my $host = 'www.example.com';
my $port = 80;
# contact the server
open_tcp(F, $host, $port)
or die 'Could not connect to server';
# Send request data
while ( my $request = <DATA> ) {
print F $request;
}
# Get Response
while ( my $response = <F> ) {
print "Response:> $response";
}
close(F);
# TCP Helper
sub open_tcp
{
# get parameters
my ($FS, $dest, $port) = #_;
my $proto = getprotobyname('tcp');
socket($FS, PF_INET, SOCK_STREAM, $proto);
my $sin = sockaddr_in($port,inet_aton($dest));
connect($FS,$sin);
my $old_fh = select($FS);
$| = 1; # don't buffer output
select($old_fh);
}
__DATA__
REPORT /calendars/johndoe/home/ HTTP/1.1
Depth: 1
Prefer: return-minimal
Content-Type: application/xml; charset=utf-8
<c:calendar-query xmlns:d="DAV:" xmlns:c="urn:ietf:params:xml:ns:caldav">
<d:prop>
<d:getetag />
<c:calendar-data />
</d:prop>
<c:filter>
<c:comp-filter name="VCALENDAR">
<c:comp-filter name="VTODO" />
</c:comp-filter>
</c:filter>
</c:calendar-query>

Web Server with HTTP::Daemon, HTML not rendering

I figured out a way to create a quick web server in Perl:
#!/usr/bin/env perl -s -wl
use strict;
use HTTP::Daemon;
use HTTP::Headers;
use HTTP::Response;
sub help {
print "$0 -port=<port-number>";
}
our $port;
our $addr = "localhost";
$port = 9000 unless defined $port;
my $server = HTTP::Daemon->new(
LocalAddr => $addr,
LocalPort => $port,
Listen => 1,
Reuse => 1,
);
die "$0: Could not setup server" unless $server;
print "$0: http://$addr:$port Accepting clients";
while (my $client = $server->accept()) {
print "$0: Client received";
$client->autoflush(1);
my $request = $client->get_request;
print "$0: Client's Request Received";
print "$0: Request: " . $request->method;
if ($request->method eq 'GET') {
my $header = HTTP::Headers->new;
$header->date( time );
$header->server("$0");
$header->content_type('text/html');
my $content = "<!doctype html><html><head><title>Hello World</title></head><body><h1>Hello World!</h1></body></html>";
my $response = HTTP::Response->new(200);
$response->content($content);
$response->header("Content-Type" => "text/html");
$client->send_response($response);
}
print "$0: Closed";
$client->close;
undef($client);
}
But for some reason, every time I access localhost:9000 it displays part of the HTTP Header - date, server, content-length and content-type - and the content. It doesn't render it as an HTML page. Is there something I'm missing?
This is caused by the -l switch:
#!/usr/bin/env perl -s -wl
^
It sets the output record separator to the value of the input record separator (a newline), which results in additional newlines being added to HTTP server output, and a broken HTTP response.

Make Perl web server deliver an ogg through HTTP to Chrome for a HTML5 audio element

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.