use
5.010;
$Neo4j::Driver::Net::HTTP::LWP::VERSION
=
'0.23'
;
our
@CARP_NOT
=
qw(Neo4j::Driver::Net::HTTP)
;
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
->{uri};
if
(
$driver
->{auth}) {
croak
"Only HTTP Basic Authentication is supported"
if
$driver
->{auth}->{scheme} ne
'basic'
;
my
$userid
= URI::Escape::uri_escape_utf8
$driver
->{auth}->{principal};
my
$passwd
= URI::Escape::uri_escape_utf8
$driver
->{auth}->{credentials};
$uri
=
$uri
->clone;
$uri
->userinfo(
"$userid:$passwd"
);
}
$self
->{uri_base} =
$uri
;
my
$version
=
$Neo4j::Driver::Net::HTTP::LWP::VERSION
;
my
$agent
=
$self
->{agent} = LWP::UserAgent->new(
agent
=>
sprintf
(
"Neo4j-Driver%s "
,
$version
?
"/$version"
:
""
),
timeout
=>
$driver
->{http_timeout},
);
$agent
->default_headers->header(
'X-Stream'
=>
'true'
);
if
(
$uri
->scheme eq
'https'
) {
croak
"HTTPS does not support unencrypted communication; use HTTP"
if
defined
$driver
->{tls} && !
$driver
->{tls};
$agent
->ssl_opts(
verify_hostname
=> 1 );
if
(
defined
(
my
$tls_ca
=
$driver
->{tls_ca} )) {
croak
"tls_ca file '$driver->{tls_ca}' can't be used: $!"
if
!
open
(
my
$fh
, '<',
$tls_ca
);
$agent
->ssl_opts(
SSL_ca_file
=>
$tls_ca
);
}
}
else
{
croak
"HTTP does not support encrypted communication; use HTTPS"
if
$driver
->{tls};
}
return
$self
;
}
sub
agent {
shift
->{agent} }
sub
uri {
shift
->{uri_base} }
sub
json_coder {
shift
->{json_coder} }
sub
result_handlers { }
sub
protocol {
shift
->{response}->protocol //
'HTTP'
}
sub
http_reason {
shift
->{response}->message //
''
}
sub
date_header {
scalar
shift
->{response}->header(
'Date'
) //
''
}
sub
http_header {
my
$response
=
shift
->{response};
return
{
content_type
=>
scalar
$response
->header(
'Content-Type'
) //
''
,
location
=>
scalar
$response
->header(
'Location'
) //
''
,
status
=>
$response
->code //
''
,
success
=>
$response
->is_success,
};
}
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
) =
@_
;
$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
,
);
}
else
{
$self
->{response} =
$self
->{agent}->
$method
(
$url
,
'Accept'
=>
$accept
,
);
}
}
1;