File Coverage

blib/lib/Dancer2/Core/Request.pm

Criterion	Covered	Total	%
statement	327	347	94.2
branch	118	142	83.1
condition	47	63	74.6
subroutine	85	92	92.3
pod	48	55	87.2
total	625	699	89.4

package Dancer2::Core::Request;
# ABSTRACT: Interface for accessing incoming requests
$Dancer2::Core::Request::VERSION = '2.1.0';
use strict;
use warnings;
use parent 'Plack::Request';

use Carp;
use Encode qw(decode FB_CROAK LEAVE_SRC);
use URI;
use URI::Escape;
use Safe::Isa;
use Hash::MultiValue;
use Ref::Util qw< is_ref is_arrayref is_hashref is_coderef >;

use Dancer2::Core::Types;
use Dancer2::Core::Request::Upload;
use Dancer2::Core::Cookie;

# add an attribute for each HTTP_* variables
# (HOST is managed manually)
my @http_env_keys = (qw/
    accept_charset
    accept_encoding
    accept_language
    connection
    keep_alive
    x_requested_with
/);

# apparently you can't eval core functions
sub accept { $_[0]->env->{'HTTP_ACCEPT'} }

eval << "_EVAL" or die $@ for @http_env_keys; ## no critic
sub $_ { \$_[0]->env->{ 'HTTP_' . ( uc "$_" ) } }
1;
_EVAL

eval {
    require Unicode::UTF8;
    no warnings qw;
    *__decode = sub { Unicode::UTF8::decode_utf8($_[0]) };
    *__valid  = sub { Unicode::UTF8::valid_utf8($_[0]) };
    1;
} or do {
    no warnings qw;
    *__decode = sub { decode( 'UTF-8', $_[0] ) };
    *__valid  = sub {
        eval { decode( 'UTF-8', $_[0], FB_CROAK | LEAVE_SRC ); 1 };
    };
};

# check presence of XS module to speedup request
our $XS_URL_DECODE         = eval { require URL::Encode::XS; 1; };
our $XS_PARSE_QUERY_STRING = eval { require CGI::Deurl::XS;  1; };
our $XS_HTTP_COOKIES       = eval { require HTTP::XSCookies; 1; };

our $_id = 0;

# self->new( env => {}, serializer => $s, is_behind_proxy => 0|1 )
sub new {
    my ( $class, @args ) = @_;

    # even sized list
    @args % 2 == 0
        or croak 'Must provide even sized list';

    my %opts = @args;
    my $env  = $opts{'env'};

    my $self = $class->SUPER::new($env);

    if ( my $s = $opts{'serializer'} ) {
        $s->$_does('Dancer2::Core::Role::Serializer')
            or croak 'Serializer provided not a Serializer object';

        $self->{'serializer'} = $s;
    }

    # additionally supported attributes
    $self->{'id'}              = ++$_id;
    $self->{'vars'}            = {};
    $self->{'is_behind_proxy'} = !!$opts{'is_behind_proxy'};
    $self->{'uri_for_route'}   = $opts{'uri_for_route'};

    $opts{'body_params'}
        and $self->{'_body_params'} = $opts{'body_params'};
    $self->{'_strict_utf8'} = !!$opts{'strict_utf8'};

    # Deserialize/parse body for HMV
    $self->data;
    $self->_build_uploads();

    return $self;
}

# a buffer for per-request variables
sub vars { $_[0]->{'vars'} }

sub var {
    my $self = shift;
    @_ == 2
      ? $self->vars->{ $_[0] } = $_[1]
      : $self->vars->{ $_[0] };
}

# I don't like this. I know send_file uses this and I wonder
# if we can remove it.
#   -- Sawyer
sub set_path_info { $_[0]->env->{'PATH_INFO'} = $_[1] }

# XXX: incompatible with Plack::Request
sub body { $_[0]->raw_body }

sub id { $_id }

# Private 'read-only' attributes for request params. See the params()
# method for the public interface.
#
# _body_params, _query_params and _route_params have setter methods that
# decode byte string to characters before setting; If you know you have
# decoded (character) params, such as output from a deserializer, you can
# set these directly in the request object hash to avoid the decode op.
sub _params { $_[0]->{'_params'} ||= $_[0]->_build_params }

sub _has_params { defined $_[0]->{'_params'} }

sub _body_params { $_[0]->{'_body_params'} ||= $_[0]->body_parameters->as_hashref_mixed }

sub _query_params { $_[0]->{'_query_params'} }

sub _set_query_params {
    my ( $self, $params ) = @_;
    $self->{_query_params} = $self->_decode( $params, 'query parameters' );
}

sub _route_params { $_[0]->{'_route_params'} ||= {} }

sub _set_route_params {
    my ( $self, $params ) = @_;
    $self->{_route_params} = $self->_decode( $params, 'route parameters' );
    $self->_build_params();
}

# XXX: incompatible with Plack::Request
sub uploads { $_[0]->{'uploads'} }

sub is_behind_proxy { $_[0]->{'is_behind_proxy'} || 0 }

sub host {
    my ($self) = @_;

    if ( $self->is_behind_proxy and exists $self->env->{'HTTP_X_FORWARDED_HOST'} ) {
        my @hosts = split /\s*,\s*/, $self->env->{'HTTP_X_FORWARDED_HOST'}, 2;
        return $hosts[0];
    } else {
        return $self->env->{'HTTP_HOST'};
    }
}

# aliases, kept for backward compat
sub agent                 { shift->user_agent }
sub remote_address        { shift->address }
sub forwarded_for_address { shift->env->{'HTTP_X_FORWARDED_FOR'} }
sub forwarded_host        { shift->env->{'HTTP_X_FORWARDED_HOST'} }

# there are two options
sub forwarded_protocol    {
    $_[0]->env->{'HTTP_X_FORWARDED_PROTO'}    ||
    $_[0]->env->{'HTTP_X_FORWARDED_PROTOCOL'} ||
    $_[0]->env->{'HTTP_FORWARDED_PROTO'}
}

sub scheme {
    my ($self) = @_;
    my $scheme = $self->is_behind_proxy
               ? $self->forwarded_protocol
               : '';

    return $scheme || $self->env->{'psgi.url_scheme'};
}

sub serializer { $_[0]->{'serializer'} }

sub data { $_[0]->{'data'} ||= $_[0]->deserialize() }

sub deserialize {
    my $self = shift;

    # don't attempt to deserialize if the form is 'multipart/form-data'
    if (
        $self->content_type
        && $self->content_type =~ /^multipart\/form-data/i
        ) {
        return;
    }


    my $serializer = $self->serializer
        or return;

    # The latest draft of the RFC does not forbid DELETE to have content,
    # rather the behaviour is undefined. Take the most lenient route and
    # deserialize any content on delete as well.
    return
      unless grep { $self->method eq $_ } qw/ PUT POST PATCH DELETE /;

    # try to deserialize
    my $body = $self->body;

    $body && length $body > 0
        or return;

    # Catch serializer fails - which is tricky as Role::Serializer
    # wraps the deserializaion in an eval and returns undef.
    # We want to generate a 500 error on serialization fail (Ref #794)
    # to achieve that, override the log callback so we can catch a signal
    # that it failed. This is messy (messes with serializer internals), but
    # "works".
    my $serializer_fail;
    my $serializer_log_cb = $serializer->log_cb;
    local $serializer->{log_cb} = sub {
        $serializer_fail = $_[1];
        $serializer_log_cb->(@_);
    };
    # work-around to resolve a chicken-and-egg issue when instantiating a
    # request object; the serializer needs that request object to deserialize
    # the body params.
    Scalar::Util::weaken( my $request = $self );
    $self->serializer->has_request || $self->serializer->set_request($request);
    my $data = $serializer->deserialize($body);
    die $serializer_fail if $serializer_fail;

    # Set _body_params directly rather than using the setter. Deserializiation
    # returns characters and skipping the decode op in the setter ensures
    # that numerical data "stays" numerical; decoding an SV that is an IV
    # converts that to a PVIV. Some serializers are picky (JSON)..
    $self->{_body_params} = $data;

    # Set body parameters (decoded HMV)
    $self->{'body_parameters'} =
        Hash::MultiValue->from_mixed( is_hashref($data) ? %$data : () );

    return $data;
}

sub uri        { $_[0]->request_uri }

sub is_head    { $_[0]->method eq 'HEAD' }
sub is_post    { $_[0]->method eq 'POST' }
sub is_get     { $_[0]->method eq 'GET' }
sub is_put     { $_[0]->method eq 'PUT' }
sub is_delete  { $_[0]->method eq 'DELETE' }
sub is_patch   { $_[0]->method eq 'PATCH' }
sub is_options { $_[0]->method eq 'OPTIONS' }

# public interface compat with CGI.pm objects
sub request_method { $_[0]->method }
sub input_handle { $_[0]->env->{'psgi.input'} }

sub to_string {
    my ($self) = @_;
    return "[#" . $self->id . "] " . $self->method . " " . $self->path;
}

sub base {
    my $self = shift;
    my $uri  = $self->_common_uri;

    return $uri->canonical;
}

sub _common_uri {
    my $self = shift;

    my $path   = $self->env->{SCRIPT_NAME};
    my $port   = $self->env->{SERVER_PORT};
    my $server = $self->env->{SERVER_NAME};
    my $host   = $self->host;
    my $scheme = $self->scheme;

    my $uri = URI->new;
    $uri->scheme($scheme);
    $uri->authority( $host || "$server:$port" );
    $uri->path( $path      || '/' );

    return $uri;
}

sub uri_base {
    my $self  = shift;
    my $uri   = $self->_common_uri;
    my $canon = $uri->canonical;

    if ( $uri->path eq '/' ) {
        $canon =~ s{/$}{};
    }

    return $canon;
}

sub path {
    my $self = shift;
    my $path = $self->env->{PATH_INFO} || '/';
    return $self->_decode_bytes( $path, 'PATH_INFO' );
}

sub dispatch_path {
    Carp::croak q{DEPRECATED: request->dispatch_path. Please use request->path instead};
}

sub uri_for {
    my ( $self, $part, $params, $dont_escape ) = @_;

    $part ||= '';
    my $uri = $self->base;

    # Make sure there's exactly one slash between the base and the new part
    my $base = $uri->path;
    $base =~ s|/$||;
    $part =~ s|^/||;
    $uri->path("$base/$part");

    $uri->query_form($params) if $params;

    return $dont_escape
           ? uri_unescape( ${ $uri->canonical } )
           : ${ $uri->canonical };
}

sub uri_for_route {
    my ( $self, @args ) = @_;

    is_coderef( $self->{'uri_for_route'} )
        or die 'uri_for_route called on a request instance without it';

    return $self->{'uri_for_route'}->(@_);
}

sub params {
    my ( $self, $source ) = @_;

    return %{ $self->_params } if wantarray && @_ == 1;
    return $self->_params if @_ == 1;

    if ( $source eq 'query' ) {
        return %{ $self->_query_params || {} } if wantarray;
        return $self->_query_params;
    }
    elsif ( $source eq 'body' ) {
        return %{ $self->_body_params || {} } if wantarray;
        return $self->_body_params;
    }
    if ( $source eq 'route' ) {
        return %{ $self->_route_params } if wantarray;
        return $self->_route_params;
    }
    else {
        croak "Unknown source params \"$source\".";
    }
}

sub query_parameters {
    my $self = shift;
    $self->{'query_parameters'} ||= do {
        if ($XS_PARSE_QUERY_STRING) {
            my $query = $self->_decode(CGI::Deurl::XS::parse_query_string(
                $self->env->{'QUERY_STRING'}
            ), 'query parameters');

            Hash::MultiValue->new(
                map {;
                    my $key = $_;
                    is_arrayref( $query->{$key} )
                    ? ( map +( $key => $_ ), @{ $query->{$key} } )
                    : ( $key => $query->{$key} )
                } keys %{$query}
            );
        } else {
            # defer to Plack::Request
            $self->_decode($self->SUPER::query_parameters, 'query parameters');
        }
    };
}

# this will be filled once the route is matched
sub route_parameters { $_[0]->{'route_parameters'} ||= Hash::MultiValue->new }

sub _set_route_parameters {
    my ( $self, $params ) = @_;
    # remove reserved splat parameter name
    # you should access splat parameters using splat() keyword
    delete @{$params}{qw};
    $self->{'route_parameters'} = Hash::MultiValue->from_mixed(
        %{ $self->_decode( $params, 'route parameters' ) }
    );
}

sub body_parameters {
    my $self = shift;
    # defer to (the overridden) Plack::Request->body_parameters
    $self->{'body_parameters'} ||= $self->_decode(
        $self->SUPER::body_parameters(),
        'body parameters',
    );
}

sub parameters {
    my ( $self, $type ) = @_;

    # handle a specific case
    if ($type) {
        my $attr = "${type}_parameters";
        return $self->$attr;
    }

    # merge together the *decoded* parameters
    $self->{'merged_parameters'} ||= do {
        my $query = $self->query_parameters;
        my $body  = $self->body_parameters;
        my $route = $self->route_parameters; # not in Plack::Request
        Hash::MultiValue->new( map $_->flatten, $query, $body, $route );
    };
}

sub captures { shift->params->{captures} || {} }

sub splat { @{ shift->params->{splat} || [] } }

# XXX: incompatible with Plack::Request
sub param { shift->params->{ $_[0] } }

sub _decode {
    my ( $self, $h, $context ) = @_;
    return if not defined $h;

    if ( !is_ref($h) && !utf8::is_utf8($h) ) {
        return $self->_decode_bytes( $h, $context );
    }
    elsif ( ref($h) eq 'Hash::MultiValue' ) {
        return Hash::MultiValue->from_mixed(
            $self->_decode( $h->as_hashref_mixed, $context )
        );
    }
    elsif ( is_hashref($h) ) {
        return { map scalar $self->_decode( $_, $context ), %{$h} };
    }
    elsif ( is_arrayref($h) ) {
        return [ map $self->_decode( $_, $context ), @{$h} ];
    }

    return $h;
}

sub _decode_bytes {
    my ( $self, $bytes, $context ) = @_;

    # If PSGI already gave us characters, avoid re-decoding.
    return $bytes if utf8::is_utf8($bytes);
    return $bytes if $bytes !~ /[\x80-\xFF]/;

    return __decode($bytes) if __valid($bytes);
    return $self->_invalid_utf8( $bytes, $context );
}

sub _invalid_utf8 {
    my ( $self, $bytes, $context ) = @_;
    my $strict = $self->{_strict_utf8};
    my $where  = $context || 'input';
    my $msg    = "Invalid UTF-8 in $where";

    $strict
        and Carp::croak($msg);

    if ( my $logger = $self->env->{'psgix.logger'} ) {
        $logger->({
            level   => 'warning',
            message => "$msg; leaving bytes unchanged",
        });
    } else {
        Carp::carp("$msg; leaving bytes unchanged");
    }

    return $bytes;
}

sub is_ajax {
    my $self = shift;

    return 0 unless defined $self->headers;
    return 0 unless defined $self->header('X-Requested-With');
    return 0 if $self->header('X-Requested-With') ne 'XMLHttpRequest';
    return 1;
}

# XXX incompatible with Plack::Request
# context-aware accessor for uploads
sub upload {
    my ( $self, $name ) = @_;
    my $res = $self->{uploads}{$name};

    return $res unless wantarray;
    return ()   unless defined $res;
    return ( is_arrayref($res) ) ? @$res : $res;
}

sub _build_params {
    my ($self) = @_;

    # params may have been populated by before filters
    # _before_ we get there, so we have to save it first
    my $previous = $self->_has_params ? $self->_params : {};

    # now parse environment params...
    my $get_params = $self->_parse_get_params();

    # and merge everything
    $self->{_params} = {
        map +( is_hashref($_) ? %{$_} : () ),
        $previous,
        $get_params,
        $self->_body_params,
        $self->_route_params,
    };

}

sub _url_decode {
    my ( $self, $encoded ) = @_;
    return URL::Encode::XS::url_decode($encoded) if $XS_URL_DECODE;
    my $clean = $encoded;
    $clean =~ tr/\+/ /;
    $clean =~ s/%([a-fA-F0-9]{2})/pack "H2", $1/eg;
    return $clean;
}

sub _parse_get_params {
    my ($self) = @_;
    return $self->_query_params if defined $self->{_query_params};

    my $query_params = {};

    my $source = $self->env->{QUERY_STRING};
    return if !defined $source || $source eq '';

    if ($XS_PARSE_QUERY_STRING) {
        $self->_set_query_params(
            CGI::Deurl::XS::parse_query_string($source) || {}
        );
        return $self->_query_params;
    }

    foreach my $token ( split /[&;]/, $source ) {
        my ( $key, $val ) = split( /=/, $token );
        next unless defined $key;
        $val = ( defined $val ) ? $val : '';
        $key = $self->_url_decode($key);
        $val = $self->_url_decode($val);

        # looking for multi-value params
        if ( exists $query_params->{$key} ) {
            my $prev_val = $query_params->{$key};
            if ( is_arrayref($prev_val) ) {
                push @{ $query_params->{$key} }, $val;
            }
            else {
                $query_params->{$key} = [ $prev_val, $val ];
            }
        }

        # simple value param (first time we see it)
        else {
            $query_params->{$key} = $val;
        }
    }
    $self->_set_query_params( $query_params );
    return $self->_query_params;
}

sub _build_uploads {
    my ($self) = @_;

    # parse body and build body params
    my $body_params = $self->_body_params;

    my $uploads = $self->SUPER::uploads;
    my %uploads;

    for my $name ( keys %$uploads ) {
        my @uploads = map Dancer2::Core::Request::Upload->new(
                             # For back-compatibility, we use a HashRef of headers
                             headers  => {@{$_->{headers}->psgi_flatten_without_sort}},
                             tempname => $_->{tempname},
                             size     => $_->{size},
                             filename => $self->_decode( $_->{filename}, 'upload filename' ),
                      ), $uploads->get_all($name);

        $uploads{$name} = @uploads > 1 ? \@uploads : $uploads[0];

        # support access to the filename as a normal param
        my @filenames = map $_->{'filename'}, @uploads;
        $self->{_body_params}{$name} =
          @filenames > 1 ? \@filenames : $filenames[0];
    }

    $self->{uploads} = \%uploads;
}

# XXX: incompatible with Plack::Request
sub cookies { $_[0]->{'cookies'} ||= $_[0]->_build_cookies }

sub _build_cookies {
    my $self    = shift;
    my $cookies = {};

    my $http_cookie = $self->header('Cookie');
    return $cookies unless defined $http_cookie; # nothing to do

    if ( $XS_HTTP_COOKIES ) {
        $cookies = HTTP::XSCookies::crush_cookie($http_cookie);
    }
    else {
        # handle via Plack::Request
        $cookies = $self->SUPER::cookies();
    }

    # convert to objects
    while (my ($name, $value) = each %{$cookies}) {
        $cookies->{$name} = Dancer2::Core::Cookie->new(
            name  => $name,
            # HTTP::XSCookies v0.17+ will do the split and return an arrayref
            value => is_arrayref($value) ? $value : [split '&', $value ]
        );
    }
    return $cookies;
}

# poor man's clone
sub _shallow_clone {
    my ($self, $params, $options) = @_;

    # shallow clone $env; we don't want to alter the existing one
    # in $self, then merge any overridden values
    my $env = { %{ $self->env }, %{ $options || {} } };

    my $new_request = __PACKAGE__->new(
        env         => $env,
        body_params => {},
    );

    # Clone and merge query params
    my $new_params = $self->params;
    $new_request->{_query_params} = { %{ $self->{_query_params} || {} } };
    $new_request->{_strict_utf8}  = $self->{_strict_utf8};
    $new_request->{query_parameters} = $self->query_parameters->clone;
    for my $key ( keys %{ $params || {} } ) {
        my $value = $params->{$key};
        $new_params->{$key} = $value;
        $new_request->{_query_params}->{$key} = $value;
        $new_request->{query_parameters}->add( $key => $value );
    }

    # Copy params (these are already decoded)
    $new_request->{_params}       = $new_params;
    $new_request->{_body_params}  = $self->{_body_params};
    $new_request->{_route_params} = $self->{_route_params};
    $new_request->{headers}       = $self->headers;

    # Copy remaining settings
    $new_request->{is_behind_proxy} = $self->{is_behind_proxy};
    $new_request->{vars}            = $self->{vars};

    # Clone any existing decoded & cached body params. (GH#1116 GH#1269)
    $new_request->{'body_parameters'} = $self->body_parameters->clone;

    # Delete merged HMV parameters, allowing them to be reconstructed on first use.
    delete $new_request->{'merged_parameters'};

    return $new_request;
}


sub _set_route {
    my ( $self, $route ) = @_;
    $self->{'route'} = $route;
}

sub route { $_[0]->{'route'} }

sub body_data {
    my $self = shift;
    return $self->data if $self->serializer;
    $self->_body_params;
    return $self->{_body_params} if keys %{ $self->{_body_params} };
    return $self->body;
}

1;

__END__