package t::HTTPServer;
use strict;
use warnings;
use IO::Socket::INET;
use Socket qw(IPPROTO_TCP TCP_NODELAY);
use Carp ();
# taken from HTTP::Status
our %STATUS_CODE = (
100 => 'Continue',
101 => 'Switching Protocols',
102 => 'Processing', # RFC 2518 (WebDAV)
200 => 'OK',
201 => 'Created',
202 => 'Accepted',
203 => 'Non-Authoritative Information',
204 => 'No Content',
205 => 'Reset Content',
206 => 'Partial Content',
207 => 'Multi-Status', # RFC 2518 (WebDAV)
300 => 'Multiple Choices',
301 => 'Moved Permanently',
302 => 'Found',
303 => 'See Other',
304 => 'Not Modified',
305 => 'Use Proxy',
307 => 'Temporary Redirect',
400 => 'Bad Request',
401 => 'Unauthorized',
402 => 'Payment Required',
403 => 'Forbidden',
404 => 'Not Found',
405 => 'Method Not Allowed',
406 => 'Not Acceptable',
407 => 'Proxy Authentication Required',
408 => 'Request Timeout',
409 => 'Conflict',
410 => 'Gone',
411 => 'Length Required',
412 => 'Precondition Failed',
413 => 'Request Entity Too Large',
414 => 'Request-URI Too Large',
415 => 'Unsupported Media Type',
416 => 'Request Range Not Satisfiable',
417 => 'Expectation Failed',
422 => 'Unprocessable Entity', # RFC 2518 (WebDAV)
423 => 'Locked', # RFC 2518 (WebDAV)
424 => 'Failed Dependency', # RFC 2518 (WebDAV)
425 => 'No code', # WebDAV Advanced Collections
426 => 'Upgrade Required', # RFC 2817
449 => 'Retry with', # unofficial Microsoft
500 => 'Internal Server Error',
501 => 'Not Implemented',
502 => 'Bad Gateway',
503 => 'Service Unavailable',
504 => 'Gateway Timeout',
505 => 'HTTP Version Not Supported',
506 => 'Variant Also Negotiates', # RFC 2295
507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
509 => 'Bandwidth Limit Exceeded', # unofficial
510 => 'Not Extended', # RFC 2774
);
sub new {
my $class = shift;
my %args = @_ == 1 ? %{$_[0]} : @_;
$args{port} || Carp::croak("missing mandatory parameter 'port'");
bless {
bufsize => 10*1024,
protocol => "HTTP/1.1",
enable_chunked => 1,
%args
}, $class;
}
sub add_trigger {
my ($self, $name, $code) = @_;
push @{$self->{triggers}->{$name}}, $code;
return $self;
}
sub call_trigger {
my ($self, $name, @args) = @_;
for my $code (@{ $self->{triggers}->{$name} || +[] }) {
$code->($self, @args);
}
}
sub run {
my ( $self, $app ) = @_;
$app = $self->fill_content_length($app);
local $SIG{PIPE} = "IGNORE";
my $sock = IO::Socket::INET->new(
Listen => SOMAXCONN,
Proto => 'tcp',
ReuseAddr => 1,
LocalAddr => '127.0.0.1',
LocalPort => $self->{port},
Timeout => 3,
) or die $!;
$sock->autoflush(1);
while ( my $csock = $sock->accept ) {
$csock->setsockopt( IPPROTO_TCP, TCP_NODELAY, 1 )
or die "setsockopt(TCP_NODELAY) failed:$!";
eval {
$self->handle_connection($csock => $app);
};
print STDERR "# $@" if $@;
}
}
sub make_header {
my ($self, $code, $headers) = @_;
my $msg = $STATUS_CODE{$code} || $code;
my $ret = "$self->{protocol} $code $msg\015\012";
for (my $i=0; $i<@$headers; $i+=2) {
$ret .= $headers->[$i] . ': ' . $headers->[$i+1] . "\015\012";
}
return $ret;
}
sub handle_connection {
my ($self, $csock, $app) = @_;
$self->call_trigger( "BEFORE_HANDLE_CONNECTION", $csock );
HANDLE_LOOP: while (1) {
$self->call_trigger( "BEFORE_HANDLE_REQUEST", $csock );
my %env;
my $buf = '';
PARSE_HTTP_REQUEST: while (1) {
my $nread = sysread( $csock, $buf, $self->{bufsize}, length($buf) );
$buf =~ s!^(\015\012)*!! if defined($buf); # for keep-alive
if ( !defined $nread ) {
die "cannot read HTTP request header: $!";
}
if ( $nread == 0 ) {
# unexpected EOF while reading HTTP request header
last HANDLE_LOOP;
}
my $ret = parse_http_request( $buf, \%env );
if ( $ret == -2 ) { # incomplete.
next;
}
elsif ( $ret == -1 ) { # request is broken
die "broken HTTP header";
}
else {
$buf = substr( $buf, $ret );
last PARSE_HTTP_REQUEST;
}
}
my $res = $app->( \%env );
my $res_header =
$self->make_header( $res->[0], $res->[1] ) . "\015\012";
$self->write_all( $csock, $res_header );
for my $body (@{$res->[2]}) {
$self->write_all( $csock, $body );
}
$self->call_trigger( "AFTER_HANDLE_REQUEST", $csock );
last HANDLE_LOOP unless $csock->opened;
}
$self->call_trigger( "AFTER_HANDLE_CONNECTION", $csock );
}
sub fill_content_length {
my ($self, $app) = @_;
sub {
my $env = shift;
my $res = $app->($env);
my $h = t::HTTPServer::Headers->new( $res->[1] );
if (
!t::HTTPServer::Util::status_with_no_entity_body( $res->[0] )
&& !$h->exists('Content-Length')
&& !$h->exists('Transfer-Encoding')
&& defined(
my $content_length = t::HTTPServer::Util::content_length( $res->[2] )
)
) {
push @{$res->[1]}, 'Content-Length' => $content_length;
}
return $res;
}
}
sub write_all {
my ( $self, $csock, $buf ) = @_;
my $off = 0;
while ( my $len = length($buf) - $off ) {
my $nwrite = $csock->syswrite( $buf, $len, $off )
or die "Cannot write response: $!";
$off += $nwrite;
}
return $off;
}
sub parse_http_request {
my ( $chunk, $env ) = @_;
Carp::croak("second param to parse_http_request should be a hashref")
unless ( ref $env || '' ) eq 'HASH';
# pre-header blank lines are allowed (RFC 2616 4.1)
$chunk =~ s/^(\x0d?\x0a)+//;
return -2 unless length $chunk;
# double line break indicates end of header; parse it
if ( $chunk =~ /^(.*?\x0d?\x0a\x0d?\x0a)/s ) {
return _parse_header( $chunk, length $1, $env );
}
return -2; # still waiting for unknown amount of header lines
}
sub _parse_header {
my($chunk, $eoh, $env) = @_;
my $header = substr($chunk, 0, $eoh,'');
$chunk =~ s/^\x0d?\x0a\x0d?\x0a//;
# parse into lines
my @header = split /\x0d?\x0a/,$header;
my $request = shift @header;
# join folded lines
my @out;
for(@header) {
if(/^[ \t]+/) {
return -1 unless @out;
$out[-1] .= $_;
} else {
push @out, $_;
}
}
# parse request or response line
my $obj;
my ($major, $minor);
my ($method,$uri,$http) = split / /,$request;
return -1 unless $http and $http =~ /^HTTP\/(\d+)\.(\d+)$/i;
($major, $minor) = ($1, $2);
my($path, $query) = ( $uri =~ /^([^?]*)(?:\?(.*))?$/s );
# following validations are just needed to pass t/01simple.t
if ($path =~ /%(?:[0-9a-f][^0-9a-f]|[^0-9a-f][0-9a-f])/i) {
# invalid char in url-encoded path
return -1;
}
if ($path =~ /%(?:[0-9a-f])$/i) {
# partially url-encoded
return -1;
}
$env->{REQUEST_METHOD} = $method;
$env->{REQUEST_URI} = $uri;
$env->{SERVER_PROTOCOL} = "HTTP/$major.$minor";
$env->{PATH_INFO} = uri_unescape($path);
$env->{QUERY_STRING} = $query || '';
$env->{SCRIPT_NAME} = '';
# import headers
my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
my $k;
for my $header (@out) {
if ( $header =~ s/^($token): ?// ) {
$k = $1;
$k =~ s/-/_/g;
$k = uc $k;
if ($k !~ /^(?:CONTENT_LENGTH|CONTENT_TYPE)$/) {
$k = "HTTP_$k";
}
} elsif ( $header =~ /^\s+/) {
# multiline header
} else {
return -1;
}
if (exists $env->{$k}) {
$env->{$k} .= ", $header";
} else {
$env->{$k} = $header;
}
}
return $eoh;
}
sub uri_unescape {
local $_ = shift;
$_ =~ s/%([0−9A−Fa−f]{2})/chr(hex($1))/eg;
$_;
}
package t::HTTPServer::Util;
# code taken from Plack::Util.
use Scalar::Util ();
sub status_with_no_entity_body {
my $status = shift;
return $status < 200 || $status == 204 || $status == 304;
}
sub content_length {
my $body = shift;
return unless defined $body;
if (ref $body eq 'ARRAY') {
my $cl = 0;
for my $chunk (@$body) {
$cl += length $chunk;
}
return $cl;
} elsif ( is_real_fh($body) ) {
return (-s $body) - tell($body);
}
return;
}
sub is_real_fh ($) {
my $fh = shift;
my $reftype = Scalar::Util::reftype($fh) or return;
if ( $reftype eq 'IO'
or $reftype eq 'GLOB' && *{$fh}{IO}
) {
# if it's a blessed glob make sure to not break encapsulation with
# fileno($fh) (e.g. if you are filtering output then file descriptor
# based operations might no longer be valid).
# then ensure that the fileno *opcode* agrees too, that there is a
# valid IO object inside $fh either directly or indirectly and that it
# corresponds to a real file descriptor.
my $m_fileno = $fh->fileno;
return 0 unless defined $m_fileno;
return 0 unless $m_fileno >= 0;
my $f_fileno = fileno($fh);
return 0 unless defined $f_fileno;
return 0 unless $f_fileno >= 0;
return 1;
} else {
# anything else, including GLOBS without IO (even if they are blessed)
# and non GLOB objects that look like filehandle objects cannot have a
# valid file descriptor in fileno($fh) context so may break.
return 0;
}
}
package t::HTTPServer::Headers;
sub new {
my ($class, $headers) = @_;
my %h;
for (my $i=0; $i<@$headers; $i++) {
my ($k, $v) = ($headers->[$i], $headers->[$i+1]);
push @{$h{lc $k}}, $v;
}
return bless \%h, $class;
}
sub exists {
my ($self, $key) = @_;
$self->{lc $key} ? 1 : 0;
}
sub header {
my ($self, $key) = @_;
my $val = $self->{lc $key};
return unless $val;
return wantarray ? @$val : join(', ', @$val);
}
1;