#!/usr/bin/perl
use IO::Socket::INET;
use IO::Socket::SSL qw/debug4/;
use IO::Select;
use HTTP::Response;
use File::MMagic;
use strict;
use warnings;
my $magic = File::MMagic->new;
my $listenport = 2222;
my $listen = IO::Socket::INET->new(
LocalPort => $listenport,
Listen => 10,
Reuse => 1,
);
my $timeout = undef;
my $rlen = 1024;
my $wlen = 4096;
my $fblen = 10240;
*$listen->{callback} = \&accepter;
my $rselect = IO::Select->new($listen);
my $wselect = IO::Select->new();
$|++;
while (1) {
eval {
# for all readable sockets
my @socks =
IO::Select::select($rselect, $wselect, undef, $timeout);
my $processed = 0;
for my $aref (@socks) {
if ($aref) {
for my $sock (@{$aref}) {
if (*$sock->{callback}) {
*$sock->{callback}($sock, $rselect, $wselect);
} else {
die "Internal error no callback on socket: $sock\n";
}
++$processed;
}
}
}
if ($processed == 0) {
# do timeout
}
};
print "uncaught error: $@\n" if $@;
}
sub accepter {
my ($sock, $rselect, $wselect) = @_;
my $acceptsock = $sock->accept;
my $sslaccept = IO::Socket::SSL->start_SSL($acceptsock,
{SSL_startHandshake => 0,
SSL_server => 1,
SSL_use_cert => 1,
SSL_verify_depth => 1,
SSL_verify_mode => 0x03,
});
$rselect->add($sslaccept);
@{*$sslaccept}{qw/sbuf size state callback/} =
('', 0, 'handshake', \&do_handshake);
# then go back to your select()
}
sub do_handshake {
my ($sock, $rselect, $wselect) = @_;
my $sslclient = $sock->accept_SSL();
if (defined($sslclient)) {
# success!
# advance the state of socket to connected, etc.
*$sock->{state} = 'need_headers';
*$sock->{callback} = \&proc_headers;
} elsif ($SSL_ERROR == SSL_WANT_READ ) {
$rselect->add($sock);
$wselect->remove($sock);
} elsif ($SSL_ERROR == SSL_WANT_WRITE) {
$rselect->remove($sock);
$wselect->add($sock);
} else {
# connect failed
# maybe log it ..
$rselect->remove($sock);
$wselect->remove($sock);
$sock->close();
}
}
sub proc_headers {
my ($sock, $rselect, $wselect) = @_;
my $props = *$sock;
# reading incoming request...
my $read = $sock->sysread( $props->{sbuf},$rlen,$props->{size});
unless (defined $read) {
$rselect->remove($sock);
die "read error: $!\n";
}
$props->{size} += $read;
if (my ($headers) =
($props->{sbuf} =~ /^(.*?)\r\n\r\n(.*)/s)) {
# we've finished reading the HTTP header
use bytes;
my ($verb, $uri) = ($headers =~ /^(\w+)\s+(\S+)/);
print "[$verb] [$uri]\n";
# put any remaining bytes of request back into the buffer
# (likely HTTP message body)
@{$props}{qw/headers verb uri sbuf size/} = (
$headers, $verb, $uri,
substr($props->{sbuf}, length($headers)),
length($props->{sbuf})
);
if (my ($bsize) =
($headers =~ /Content-Length\s*:\s*(\d+)/s)) {
# need to read HTTP message body of length $bsize
@{$props}{qw/need state callback/} =
($bsize, 'need_body', \&read_body);
# already in $rselect
} else {
$rselect->remove($sock);
request_done($sock, $rselect, $wselect, '');
}
}
}
sub read_body {
my ($sock, $rselect, $wselect) = @_;
my $props = *$sock;
# reading body...
my $size = $props->{need} < $rlen ? $props->{need} : $rlen;
my $read = $sock->sysread(
$props->{sbuf},$size,$props->{size});
$props->{size} += $read;
$props->{need} -= $read;
# done reading body (if we've read enough bytes)
request_done($sock, $rselect, $wselect, $props->{sbuf})
unless $props->{need};
}
sub request_done {
my ($sock, $rselect, $wselect, $body) = @_;
my $props = *$sock;
@{$props}{qw/size sbuf body/} = (0, '', $body);
# request read, build response...
my $msg;
#
# YES: I'm aware the path is tainted/insecure.
# This is just an example to demonstrate failure.
#
if (-f ".".$props->{uri}) {
# the requested file was found, so...
# determine mime-type
my $type = $magic->checktype_filename(
".".$props->{uri}) || "text/html";
# read local file
open F, "<.".$props->{uri};
my ($buf, $len) = ('', 0);
while (my $read = sysread(F, $buf, $fblen, $len)) {
$len += $read;
}
close F;
# will send positive response
$msg = [200, 'OK', $type, $buf];
} else {
# will send negative response
$msg = [404, 'File Not Found', 'text/html', 'What file?!?'];
}
{
use bytes;
# construct HTTP response as a string
$props->{wbuf} =
'HTTP/1.1 '.
HTTP::Response->new(
$msg->[0] => $msg->[1],
['Content-Type' => $msg->[2],
'Content-Length' => length($msg->[3]),
'Connection' => 'close'],
$msg->[3]
)->as_string;
$props->{wdone} = 0;
$props->{wsize} = length($props->{wbuf});
$props->{state} = 'response_pending';
$props->{callback} = \&send_response;
}
send_response($sock, $rselect, $wselect);
}
sub send_response {
# writing outgoing response...
my ($sock, $rselect, $wselect) = @_;
my $props = *$sock;
my $size = $props->{wsize} < $wlen ? $props->{wsize} : $wlen;
$wselect->add($sock);
my $wrote = $sock->syswrite(
$props->{wbuf},$size,$props->{wdone});
unless (defined $wrote) {
$wselect->remove($sock);
die "write error: $!\n";
}
$props->{wdone} += $wrote;
if ($props->{wdone} == $props->{wsize}) {
# we're done sending the request, ready for another
# NOTE: IO::Socket::SSL docs say we can't do multiple
# requests, but it does work in the absense of
# peer cert authentication.
$wselect->remove($sock);
if ($props->{keepalive}) {
$rselect->add($sock);
$props->{wdone} = 0;
$props->{wsize} = 0;
$props->{wbuf} = '';
$props->{state} = 'need_headers';
$props->{callback} = \&proc_headers;
# seemingly correct, but blocks listener socket
#$sock->close(SSL_no_shutdown => 1);
} else {
$sock->close();
}
}
}
