view release on metacpan or  search on metacpan

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

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;

        my $chunk_length = length($starter) + $need + 2;
        return if length($$refdata) < $chunk_length;
 
        if($need!=0)
        {   $req->add_content(substr $$refdata, length($starter), $need);
            substr($$refdata, 0, $chunk_length) = '';
            return;  # get more chunks
        }

        return if $$refdata !~ m/\n\r?\n/;  # need footer
        my ($footer) = $$refdata =~ s/^0+\r?\n(.*?\r?\n)\r?\n//;
        my $header   = $req->headers;
        HTTP::Message->parse($footer)->headers
                     ->scan(sub { $header->push_header(@_)} );

        $header->_header('Content-Length' => length ${$req->content_ref});
        $header->remove_header('Transfer-Encoding');
    }
    elsif($te ne '')
    {   my $resp = $self->sendStatus($req, RC_NOT_IMPLEMENTED);
        trace "Unsupported transfer encoding $te";
        $self->cancelConnection;
        return $resp;
    }
    elsif(defined $cl)
    {   return if defined $cl && length($$refdata) < $cl;
        $req->content(substr $$refdata, 0, $cl, '');
    }
    elsif(($headers->header('Content-Type') || '')
            =~ m/^multipart\/\w+\s*;.*boundary\s*=(["']?)\s*(\w+)\1/i)

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

    $mux->shutdown($fh, 1);
}

# This is the most tricky part: each connection may have multiple
# requests queued.  If the handler returns a response object, the
# the response succeeded.  Otherwise, other IO will need to be performed:
# we simply stop.  When the other IO has completed, it will call this
# function again, to resolve the other requests.

sub addRequest($)
{   my ($self, $req) = @_;
    my $queue = $self->{HSC_requests};
    push @$queue, $req;

    # handler initiated by first request in queue, then auto-continues
    $self->handleRequests
        if @$queue==1;
}

sub handleRequests()
{   my ($self) = @_;
    my $queue  = $self->{HSC_requests};

  REQUEST:
    while(@$queue)
    {   my $req = shift @$queue;
        my $vhostn  = $req->header('Host');
        $vhostn     =~ s/\:(\d+)$//;   # strip optional port; ignored for now

        if(!defined $vhostn)
        {   if($req->protocol gt HTTP_1_1)
            {   $self->sendStatus($req, RC_MULTIPLE_CHOICES,
                "explicit virtual host required in protocol ".$req->protocol);
                next REQUEST;
            }
            $vhostn = 'default';
        }

        my $vhost   = $self->{HSC_daemon}->virtualHost($vhostn);
        unless(defined $vhost)
        {   $self->sendStatus($req, RC_NOT_FOUND, "no virtual host $vhostn");
            next REQUEST;
        }

        my $resp = $vhost->handleRequest($self, $req);
        defined $resp
            or last REQUEST;  # no answer==waiting in MUX
    }
}


sub sendResponse($$$;$)
{   my ($self, $req, $status, $header, $content) = @_;
    my $protocol = $req->protocol;
    defined $content or $content = '';

    if($protocol ge HTTP_1_0)
    {   push @$header
          , Date       => time2str(time)
          , Connection => ($self->{HSC_no_more} ? 'close' : 'keep-alive')
          , @default_headers;

        push @$header
          , ref $content eq 'CODE'
            ? ('Transfer-Encoding' => 'chunked')
            : ('Content-Length'    => length $content);
    }
    else
    {   undef $header;
    }

    my $resp = HTTP::Response->new($status, status_message($status),$header);
    $resp->request($req);
    $resp->protocol($protocol);

    my ($mux, $fh) = @$self{'HSC_mux', 'HSC_fh'};
    my $headtxt = $resp->as_string("\r\n");
    my $size    = length $headtxt;
    if($req->method eq 'HEAD')
    {   $mux->write($fh, $headtxt);
    }
    elsif(ref $content eq 'CODE')
    {   # create chunked
        $mux->write($fh, $headtxt);
        $size = 0;
        while(1)
        {   my $chunk = $content->();
            defined $chunk or last;
            length  $chunk or next;
            my $hexlen = sprintf "%x", length $chunk;
            $mux->write($fh, "$hexlen\r\n$chunk\r\n");
            $size     += length($hexlen) + length($chunk) + 4;
        }
        $mux->write($fh, "0\r\n\r\n");   # end chunks and no footer
        $size += 5;
    }
    else
    {   $resp->content_ref(\$content);
        $mux->write($fh, $headtxt.$content);
    }

    info $req->id." $status ${size}b";
    $resp;
}


sub sendStatus($$;$)
{   my ($self, $req, $status, $text) = @_;
    my $descr   = defined $text && length $text ? "\n<p>$text</p>" : '';
    my @headers = ('Content-Type' => 'text/html');
    my $message = status_message $status;

    $self->sendResponse($req, $status, \@headers, <<__CONTENT);
<html><head><title>$status $message</title></head>
<body><h1>$status $message</h1>$descr
</body></html>
__CONTENT
}


sub sendRedirect($$$;$)
{   my ($self, $req, $status, $location, $content) = @_;
    is_redirect $status
        or panic "Status '$status' is not redirect";

    my @headers = (Location => $location);
    if(defined $content && length $content)
    {   my $ct  = $content =~ m/^\s*\</ ? 'text/html' : 'text/plain';
        push @headers, 'Content-Type' => $ct;
    }

    $self->sendResponse($req, $status, \@headers, $content);
}


sub sendFile($$;$$)
{   my ($self, $req, $file, $headers, $user_callback) = @_;
    $user_callback ||= sub {};
    my ($callback, @headers);
    push @headers, @$headers if $headers;

    my $from_fh;
    if(ref $file)
    {   $from_fh = $file;
        $callback = sub
          { $user_callback->(@_);
            $self->handleRequests;
          };
    }
    else
    {   -e $file or return
            $self->sendStatus(RC_NOT_FOUND, "file $file does not exist");

        -f _ or return
            $self->sendStatus(RC_NOT_ACCEPTABLE, "not a file $file");

        sysopen $from_fh, $file, O_RDONLY
            or return $self->sendStatus(RC_FORBIDDEN, "no access to $file");

        $callback = sub
          { $user_callback->(@_);
            close $from_fh;  # read errors are ignored
            $self->handleRequests;
          };

        my ($ct, $ce) = guess_media_type $file;
        push @headers
          , Date       => time2str(time)
          , Connection => ($self->{HSC_no_more} ? 'close' : 'keep-alive')
          , @default_headers
          , 'Content-Type' => $ct;
        push @headers, 'Content-Encoding' => $ce if $ce;
    }

    my ($size, $mtime) = (stat $from_fh)[7,9];
    push @headers, 'Content-Length' => $size if $size;

    my $status = RC_OK;
    if($mtime)
    {   if(my $ims = $req->header('If-Modified-Since'))
        {   my $imstime = str2time $ims;
            $status     = RC_NOT_MODIFIED if $mtime==$imstime;
        }
        push @headers, 'Last-Modified' => time2str($mtime);
    }

    my $resp = HTTP::Response
        ->new($status, status_message($status), \@headers);

    $resp->request($req);
    $resp->protocol($req->protocol);

    my ($mux, $clientfh) = @$self{'HSC_mux', 'HSC_fh'};
    $mux->write($clientfh, $resp->as_string("\r\n"));

    if($req->method eq 'HEAD')
    {   info $req->id." sent head of $file";
        return $resp;
    }
    if($status==RC_NOT_MODIFIED)
    {   info $req->id." file $file was not modified";
        return $resp;
    }

    info $req->id." sent file $file, ${size}b";

    my $pump = _PUMP::PROXY->new($clientfh, $callback);
    $mux->add($from_fh);
    $mux->set_callback_object($pump, $from_fh);
    undef;
}


sub cancelConnection()
{   my $self = shift;
    info $self->id.' connection cancelled';
    delete @$self{'HSC_next', 'HSC_requests'};
    $self->closeConnection;
}


sub closeConnection()
{   my $self = shift;
    info $self->id.' connection closed';
    $self->{HSC_no_more}++;
}


my %filetype =