view release on metacpan or  search on metacpan

lib/HTTP/Promise/Parser.pm  view on Meta::CPAN

    my $bkp_version;
    # try-catch
    local $@;
    eval
    {
        if( $opts->{request} )
        {
            # We have to do this, because of a bug in TTP::Parser2::XS where HTTP/2 is not supported.
            # We save the value and replace it with one supported and we put it back after in
            # the data we return.
            # <https://rt.cpan.org/Ticket/Display.html?id=142808>
            if( index( $$str, 'HTTP/2' ) != -1 )
            {
                if( $$str =~ s,^((?:\S+)[[:blank:]\h]+(?:\S+)[[:blank:]\h]+HTTP/)(2(?:\.\d)?),${1}1.1, )
                {
                    $bkp_version = $2;
                }
            }
            $len = HTTP::Parser2::XS::parse_http_request( $$str, $r );
        }
        elsif( $opts->{response} )
        {
            if( index( $$str, 'HTTP/2' ) != -1 )
            {
                if( $$str =~ s,^(HTTP/)(2(?:\.\d)?),${1}1.1, )
                {
                    $bkp_version = $2;
                }
            }
            $len = HTTP::Parser2::XS::parse_http_response( $$str, $r );
        }
    };
    if( $@ )
    {
        return( $self->error({ code => 400, message => $@, class => $EXCEPTION_CLASS }) );
    }
    
    if( $len == -1 )
    {
        return( $self->error({ code => 400, message => 'Bad request', class => $EXCEPTION_CLASS }) );
    }
    elsif( $len == -2 && $max_headers_size > 0 && length( $$str ) > $max_headers_size )
    {
        # 431: HTTP request header fields too large
        # 413: Request entity too large
        return( $self->error({ code => 413, message => 'Incomplete and too long request', class => $EXCEPTION_CLASS }) );
    }
    # Which one is best?
    # 406 Unacceptable
    # 411 Length required
    # 417 Expectation failed
    # 422 Unprocessable entity
    # 425 Too early
    elsif( $len == -2 )
    {
        return( $self->error({ code => 425, message => 'Incomplete request, call again when there is more data.', class => $EXCEPTION_CLASS }) );
    }
    # response headers:
    # {
    #   "_content_length" => 15,
    #   "_keepalive"      => 0,
    #   "_message"        => "OK",
    #   "_protocol"       => "HTTP/1.0",
    #   "_status"         => 200,
    #   "content-length"  => [15],
    #   "content-type"    => ["text/plain"],
    #   "host"            => ["example.com"],
    #   "user-agent"      => ["hoge"],
    # }
    # request headers:
    # {
    #   "_content_length" => 27,
    #   "_keepalive"      => 1,
    #   "_method"         => "POST",
    #   "_protocol"       => "HTTP/1.1",
    #   "_query_string"   => "",
    #   "_request_uri"    => "/test",
    #   "_uri"            => "/test",
    #   "content-length"  => [27],
    #   "content-type"    => ["application/x-www-form-urlencoded"],
    #   "host"            => ["foo.example"],
    # }
    $r->{_protocol} = "HTTP/${bkp_version}" if( defined( $bkp_version ) );
    # warn( "HTTP::Parser2::XS->parse_headers_xs: bytes read ($len) differs from _content_length (", ( $r->{_content_length} // '' ), ")\n" ) if( defined( $r->{_content_length} ) && length( $r->{_content_length} ) && $len != $r->{_content_length} && ...
    my $def = { length => $len };
    # Sadly enough, HTTP::Parser2::XS does not provide the order of the header and
    # although we could find out ourself, it would defeat the purpose of using an XS module
    # so we default to alphabetical order
    # If this is really important, you can use parse_request method instead
    my $headers = $self->new_array;
    # Skip keys that start with _. They are private properties
    for( sort( grep( !/^_/, keys( %$r ) ) ) )
    {
        my $k = $_;
        $k =~ tr/-/_/ if( $opts->{convert_dash} );
        $headers->push( $k => $r->{ $_ } );
    }
    $def->{headers} = HTTP::Promise::Headers->new( @$headers );
    if( $opts->{request} )
    {
        @$def{qw( method protocol )} = @$r{qw( _method _protocol )};
        $def->{uri} = URI->new( $r->{_request_uri} ) if( exists( $r->{_request_uri} ) && length( $r->{_request_uri} ) );
    }
    elsif( $opts->{response} )
    {
        @$def{qw( code status protocol )} = @$r{qw( _status _message _protocol )};
    }
    $def->{version} = $self->parse_version( $r->{_protocol} ) || return( $self->pass_error );
    # It seems 
    while( substr( $$str, 0, $len ) =~ /$CRLF($CRLF)$/ )
    {
        $len -= length( $1 );
    }
    $def->{length} = $len;
    return( $def );
}

sub parse_multi_part
{
    my $self = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    my $ent = $opts->{entity} ||
        return( $self->error({ code => 500, message => "No entity object was provided." }) );
    my $reader = $opts->{reader} ||
        return( $self->error({ code => 500, message => "No reader object was provided." }) );
    my $headers = $ent->headers ||
        return( $self->error({ code => 500, message => "No headers object found in entity object." }) );
    my $ct = $headers->content_type;
    my $h = $headers->new_field( 'Content-Type' => $ct ) || return( $self->pass_error( $headers->error ) );
    my $boundary = $h->boundary ||
        return( $self->error( "No boundary could be found in the Content-Type header '$ct'" ) );
    my $max_in_memory = $self->max_body_in_memory_size;
    my $default_mime = $DEFAULT_MIME_TYPE || 'application/octet-stream';