view release on metacpan or  search on metacpan

lib/HTTP/Server/Connection.pm  view on Meta::CPAN

use HTTP::Status;
use HTTP::Date       qw(time2str str2time);
use URI              ();
use LWP::MediaTypes  qw(guess_media_type);
use Fcntl            qw(O_RDONLY);
use Scalar::Util     qw(weaken);
use Socket           qw(unpack_sockaddr_in inet_ntoa);
use Storable         qw(freeze thaw);
use Fcntl            qw(:mode);
use POSIX            qw(strftime);

use Log::Report 'httpd-multiplex', syntax => 'SHORT';

use constant
 { HTTP_0_9 => 'HTTP/0.9'
 , HTTP_1_0 => 'HTTP/1.0'
 , HTTP_1_1 => 'HTTP/1.1'
 };

my @stat_fields =
   qw/dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks/;

my @default_headers;
sub setDefaultHeaders(@) {my $class = shift; push @default_headers, @_};

# oops, dirty hack
sub HTTP::Request::id() { shift->{HSC_id} }


my $conn_id = 'C0000000';

sub new($$$$)
{   my ($class, $mux, $fh, $daemon) = @_;
    my $self = bless {}, $class;
    $self->{HSC_requests} = [];
    $self->{HSC_mux}      = $mux;
    $self->{HSC_fh}       = $fh;
    $self->{HSC_session}  = HTTP::Server::Session->new;  # will change

    $self->{HSC_daemon}   = $daemon;
    weaken $self->{HSC_daemon};

    $self->{HSC_connect}  = time;
    $self->{HSC_conn_id}  = ++$conn_id;
    $self->{HSC_reqcount} = 0;

    my $peername          = $fh->peername;
    my ($port, $addr)     = unpack_sockaddr_in $peername;
    my $ip                = inet_ntoa $addr;
    info "$self->{HSC_conn_id} contacted by $ip:$port";

    my %client            = (port => $port, ip => $ip, host => undef);
    $daemon->dnslookup($self, $ip, \$client{host});
    $self->{HSC_client}   = \%client;

    $self;
}

sub client()  {shift->{HSC_client}}
sub session() {shift->{HSC_session}}
sub id()      {shift->{HSC_conn_id}}

# new text was received.  Collect it into an HTTP::Request
sub mux_input($$$)
{   my ($self, $mux, $fh, $refdata) = @_;
    my $req = $self->{HSC_next};

    # ignore input for closing, connection can still be writing
    if(!$req && $self->{HSC_no_more})
    {   $$refdata = '';
        return;
    }

    my $headers;
    if($req)
    {   $headers  = $req->headers;
    }
    else
    {   $$refdata =~ s/^\s+//s;                     # strip leading blanks
        $$refdata =~ s/(.*?)\r\n\r\n//s or return;  # not whole header yet
        $req  = $self->{HSC_next} = HTTP::Request->parse($1);
        $req->{HSC_id}
           = $self->{HSC_conn_id} . sprintf('-%02d', $self->{HSC_reqcount}++);

        my $proto = $req->protocol;
        $req->protocol($proto = HTTP_0_9)
            unless $proto;

        $headers  = $req->headers;
        $self->{HSC_no_more}++
            if $req->protocol lt HTTP_1_1
            || lc($headers->header('Connection') || '') ne 'keep-alive';

        if($proto lt HTTP_1_0)
        {   $self->{take_all}++;
            return;
        }
      
        if(my $expect = $headers->header('Expect'))
        {   if(lc $expect ne '100-continue')
            {   my $resp = $self->sendStatus($req, RC_EXPECTATION_FAILED);
                trace "Unsupported Expect value '$expect'";
                $self->cancelConnection;
                return $resp;
            }
            $self->sendStatus($req, RC_CONTINUE);
        }
    }

    my $te = lc($headers->header('Transfer-Encoding') || '');
    my $cl = $headers->header('Content-Length') || 0;

    if($te eq 'chunked')
    {   my ($starter, $len) = $$refdata =~ m/^((\S+)\r?\n)/ or return;
        if($len !~ m/^[0-9a-fA-F]+$/)
        {   my $resp = $self->sendStatus($req, RC_BAD_REQUEST);
            trace "Bad chunk header $len";
            $self->cancelConnection;
            return $resp;
        }
        my $need = hex $len;