File Coverage

blib/lib/HTTP/Engine/Request.pm

Criterion	Covered	Total	%
statement	12	12	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	16	16	100.0

package HTTP::Engine::Request;
use Any::Moose;
use HTTP::Headers::Fast;
use HTTP::Engine::Types::Core qw( Uri Header );
use URI::QueryParam;
require Carp; # Carp->import is too heavy =(

# Mouse, Moose role merging is borked with attributes
#with qw(HTTP::Engine::Request);

# this object constructs all our lazy fields for us
has request_builder => (
    does     => "HTTP::Engine::Role::RequestBuilder",
    is       => "rw",
    required => 1,
);

sub BUILD {
    my ( $self, $param ) = @_;

    foreach my $field qw(base path) {
        if ( my $val = $param->{$field} ) {
            $self->$field($val);
        }
    }
}

has _connection => (
    is => "ro",
    isa => 'HashRef',
    required => 1,
);

has "_read_state" => (
    is => "rw",
    lazy_build => 1,
);

sub _build__read_state {
    my $self = shift;
    $self->request_builder->_build_read_state($self);
}

has connection_info => (
    is => "rw",
    isa => "HashRef",
    lazy_build => 1,
);

sub _build_connection_info {
    my $self = shift;
    $self->request_builder->_build_connection_info($self);
}

has cookies => (
    is      => 'rw',
    isa     => 'HashRef',
    lazy_build => 1,
);

sub _build_cookies {
    my $self = shift;
    $self->request_builder->_build_cookies($self);
}

foreach my $attr qw(address method protocol user port _https_info request_uri) {
    has $attr => (
        is => 'rw',
        # isa => "Str",
        lazy => 1,
        default => sub { shift->connection_info->{$attr} },
    );
}
has query_parameters => (
    is      => 'rw',
    isa     => 'HashRef',
    lazy_build => 1,
);

sub _build_query_parameters {
    my $self = shift;
    $self->uri->query_form_hash;
}

# https or not?
has secure => (
    is      => 'rw',
    isa     => 'Bool',
    lazy_build => 1,
);

sub _build_secure {
    my $self = shift;

    if ( my $https = $self->_https_info ) {
        return 1 if uc($https) eq 'ON';
    }

    if ( my $port = $self->port ) {
        return 1 if $port == 443;
    }

    return 0;
}

# proxy request?
has proxy_request => (
    is         => 'rw',
    isa        => 'Str', # TODO: union(Uri, Undef) type
#    coerce     => 1,
    lazy_build => 1,
);

sub _build_proxy_request {
    my $self = shift;
    return '' unless $self->request_uri;                   # TODO: return undef
    return '' unless $self->request_uri =~ m!^https?://!i; # TODO: return undef
    return $self->request_uri;                             # TODO: return URI->new($self->request_uri);
}

has uri => (
    is     => 'rw',
    isa => Uri,
    coerce => 1,
    lazy_build => 1,
    handles => [qw(base path)],
);

sub _build_uri {
    my $self = shift;
    $self->request_builder->_build_uri($self);
}

has raw_body => (
    is      => 'rw',
    isa     => 'Str',
    lazy_build => 1,
);

sub _build_raw_body {
    my $self = shift;
    $self->request_builder->_build_raw_body($self);
}

has headers => (
    is      => 'rw',
    isa => Header,
    coerce  => 1,
    lazy_build => 1,
    handles => [ qw(content_encoding content_length content_type header referer user_agent) ],
);

sub _build_headers {
    my $self = shift;
    $self->request_builder->_build_headers($self);
}

# Contains the URI base. This will always have a trailing slash.
# If your application was queried with the URI C then C is C.

has hostname => (
    is      => 'rw',
    isa     => 'Str',
    lazy_build => 1,
);

sub _build_hostname {
    my $self = shift;
    $self->request_builder->_build_hostname($self);
}

has http_body => (
    is         => 'rw',
    isa        => 'HTTP::Body',
    lazy_build => 1,
    handles => {
        body_parameters => 'param',
        body            => 'body',
    },
);

sub _build_http_body {
    my $self = shift;
    $self->request_builder->_build_http_body($self);
}

# contains body_params and query_params
has parameters => (
    is      => 'rw',
    isa     => 'HashRef',
    lazy_build => 1,
);

sub _build_parameters {
    my $self = shift;

    my $query = $self->query_parameters;
    my $body = $self->body_parameters;

    my %merged;

    foreach my $hash ( $query, $body ) {
        foreach my $name ( keys %$hash ) {
            my $param = $hash->{$name};
            push( @{ $merged{$name} ||= [] }, ( ref $param ? @$param : $param ) );
        }
    }

    foreach my $param ( values %merged ) {
        $param = $param->[0] if @$param == 1;
    }

    return \%merged;
}

has uploads => (
    is      => 'rw',
    isa     => 'HashRef',
    lazy_build => 1,
);

sub _build_uploads {
    my $self = shift;
    $self->request_builder->_prepare_uploads($self);
}

# aliases
*body_params  = \&body_parameters;
*input        = \&body;
*params       = \¶meters;
*query_params = \&query_parameters;
*path_info    = \&path;

sub cookie {
    my $self = shift;

    return keys %{ $self->cookies } if @_ == 0;

    if (@_ == 1) {
        my $name = shift;
        return undef unless exists $self->cookies->{$name}; ## no critic.
        return $self->cookies->{$name};
    }
    return;
}

sub param {
    my $self = shift;

    return keys %{ $self->parameters } if @_ == 0;

    if (@_ == 1) {
        my $param = shift;
        return wantarray ? () : undef unless exists $self->parameters->{$param};

        if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
            return (wantarray)
              ? @{ $self->parameters->{$param} }
                  : $self->parameters->{$param}->[0];
        } else {
            return (wantarray)
              ? ( $self->parameters->{$param} )
                  : $self->parameters->{$param};
        }
    } else {
        my $field = shift;
        $self->parameters->{$field} = [@_];
    }
}

sub upload {
    my $self = shift;

    return keys %{ $self->uploads } if @_ == 0;

    if (@_ == 1) {
        my $upload = shift;
        return wantarray ? () : undef unless exists $self->uploads->{$upload};

        if (ref $self->uploads->{$upload} eq 'ARRAY') {
            return (wantarray)
              ? @{ $self->uploads->{$upload} }
          : $self->uploads->{$upload}->[0];
        } else {
            return (wantarray)
              ? ( $self->uploads->{$upload} )
          : $self->uploads->{$upload};
        }
    } else {
        while ( my($field, $upload) = splice(@_, 0, 2) ) {
            if ( exists $self->uploads->{$field} ) {
                for ( $self->uploads->{$field} ) {
                    $_ = [$_] unless ref($_) eq "ARRAY";
                    push(@{ $_ }, $upload);
                }
            } else {
                $self->uploads->{$field} = $upload;
            }
        }
    }
}

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

    Carp::carp( 'No arguments passed to uri_with()' ) unless $args;

    for my $value (values %{ $args }) {
        next unless defined $value;
        for ( ref $value eq 'ARRAY' ? @{ $value } : $value ) {
            $_ = "$_";
            utf8::encode( $_ );
        }
    };

    my $uri = $self->uri->clone;

    $uri->query_form( {
        %{ $uri->query_form_hash },
        %{ $args },
    } );
    return $uri;
}

sub as_http_request {
    my $self = shift;
    require 'HTTP/Request.pm'; ## no critic
    HTTP::Request->new( $self->method, $self->uri, $self->headers, $self->raw_body );
}

sub absolute_url {
    my ($self, $location) = @_;

    unless ($location =~ m!^https?://!) {
        return URI->new( $location )->abs( $self->base );
    } else {
        return $location;
    }
}

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

    if ( @args ) {
        Carp::croak "The HTTP::Request method 'content' is unsupported when used as a writer, use HTTP::Engine::RequestBuilder";
    } else {
        return $self->raw_body;
    }
}

sub as_string {
    my $self = shift;
    $self->as_http_request->as_string; # FIXME not efficient
}

sub parse {
    Carp::croak "The HTTP::Request method 'parse' is unsupported, use HTTP::Engine::RequestBuilder";
}

no Any::Moose;
__PACKAGE__->meta->make_immutable(inline_destructor => 1);
1;
__END__