File Coverage

lib/Neo4j/Driver/Net/HTTP/LWP.pm

Criterion	Covered	Total	%
statement	78	79	98.7
branch	25	26	96.1
condition	24	24	100.0
subroutine	20	20	100.0
pod	10	12	100.0
total	157	161	98.7

use 5.010;
use strict;
use warnings;
use utf8;

package Neo4j::Driver::Net::HTTP::LWP;
# ABSTRACT: HTTP network adapter for libwww-perl
$Neo4j::Driver::Net::HTTP::LWP::VERSION = '0.38';

use Carp qw(croak);
our @CARP_NOT = qw(Neo4j::Driver::Net::HTTP);

use JSON::MaybeXS 1.003003 qw();
use LWP::UserAgent 6.04 qw();
use URI 1.31;

my $CONTENT_TYPE = 'application/json';


sub new {
	my ($class, $driver) = @_;

	my $self = bless {
		json_coder => JSON::MaybeXS->new(utf8 => 1, allow_nonref => 0),
	}, $class;

	my $uri = $driver->config('uri');
	if (my $auth = $driver->config('auth')) {
		croak "Only HTTP Basic Authentication is supported" if $auth->{scheme} ne 'basic';
		my $userid = $auth->{principal}   // '';
		my $passwd = $auth->{credentials} // '';
		my $userinfo = join ':', map {
			utf8::encode $_ if utf8::is_utf8 $_;  # uri_escape doesn't handle wide characters
			URI::Escape::uri_escape $_;
		} $userid, $passwd;
		$uri = $uri->clone;
		$uri->userinfo($userinfo);
	}
	$self->{uri_base} = $uri;

	my $version = $Neo4j::Driver::Net::HTTP::LWP::VERSION;
	my $agent = $self->{agent} = LWP::UserAgent->new(
		# User-Agent: Neo4j-Driver/0.21 libwww-perl/6.52
		agent => sprintf("Neo4j-Driver%s ", $version ? "/$version" : ""),
		timeout => $driver->config('timeout'),
	);
	$agent->default_headers->header( 'X-Stream' => 'true' );

	if ($uri->scheme eq 'https') {
		my $unencrypted = defined $driver->config('encrypted') && ! $driver->config('encrypted');
		croak "HTTPS does not support unencrypted communication; use HTTP" if $unencrypted;
		$agent->ssl_opts( verify_hostname => 1 );
		if (defined( my $trust_ca = $driver->config('trust_ca') )) {
			croak "trust_ca file '$trust_ca' can't be used: $!" if ! open(my $fh, '<', $trust_ca);
			$agent->ssl_opts( SSL_ca_file => $trust_ca );
		}
	}
	else {
		croak "HTTP does not support encrypted communication; use HTTPS" if $driver->config('encrypted');
	}

	return $self;
}


sub protocol {
	# uncoverable pod (see Deprecations.pod)
	my ($self) = @_;
	warnings::warnif deprecated => __PACKAGE__ . "->protocol() is deprecated";
	return $self->{response}->protocol // 'HTTP';
}


sub agent {
	# uncoverable pod (see Deprecations.pod)
	my ($self) = @_;
	warnings::warnif deprecated => __PACKAGE__ . "->agent() is deprecated; call ua() instead";
	return $self->{agent};
}


sub ua { shift->{agent} }

sub uri { shift->{uri_base} }

sub json_coder { shift->{json_coder} }

sub http_reason { shift->{response}->message // '' }

sub date_header { scalar shift->{response}->header('Date') // '' }


sub http_header {
	my $response = shift->{response};
	my $header = {
		content_type => scalar $response->header('Content-Type') // '',
		location     => scalar $response->header('Location') // '',
		status       => $response->code // '',
		success      => $response->is_success,
	};
	if ( ! $header->{success} && $response->header('Client-Warning') // '' eq 'Internal response' ) {
		$header->{content_type} = '';
		$header->{status}       = '';
	}
	return $header;
}


sub fetch_event {
	my ($self) = @_;
	$self->{buffer} = [grep { length } split m/\n|\x{1e}/, $self->fetch_all] unless defined $self->{buffer};
	return shift @{$self->{buffer}};
}


sub fetch_all {
	my ($self) = @_;
	return $self->{response}->content;
}


sub request {
	my ($self, $method, $url, $json, $accept, $mode) = @_;

	$self->{buffer} = undef;

	$url = URI->new_abs( $url, $self->{uri_base} );
	$method = lc $method;
	if ($json) {
		$self->{response} = $self->{agent}->$method(
			$url,
			'Accept' => $accept,
			'Content' => $self->{json_coder}->encode($json),
			'Content-Type' => $CONTENT_TYPE,
			$mode ? ('Access-Mode' => $mode) : ()
		);
	}
	else {
		$self->{response} = $self->{agent}->$method(
			$url,
			'Accept' => $accept,
		);
	}
}


1;

__END__