The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#$Id$
use v5.10;
package REST::Neo4p::Agent::HTTP::Thin;
use base qw/HTTP::Thin REST::Neo4p::Agent/;
use URI::Escape;
use MIME::Base64;
use REST::Neo4p::Exceptions;
use strict;
use warnings;

BEGIN {
  $REST::Neo4p::Agent::HTTP::Thin::VERSION = 0.3010;
}

my $unsafe = "^A-Za-z0-9\-\._~:+?%&=";
sub agent {
  my $self = shift;
  return $self->{agent} = $_[0] if @_;
  return $self->{agent};
}

sub credentials {
  my $self = shift;
  my ($srv,$realm,$user,$pwd) = @_;
  $self->{_user} = $user;
  $self->{_pwd} = $pwd;
  if ($user && $pwd) {
    $self->default_header('Authorization' => encode_base64("$user:$pwd",''));
  }
  1;
}

sub default_header {
  my $self = shift;
  my ($hdr,$value) = @_;
  $self->{default_headers}->{$hdr} = $value;
  return;
}

sub add_header { shift->{default_headers}->{$_[0]} = $_[1] }
sub remove_header { delete shift->{default_headers}->{$_[0]} }

sub protocols_allowed {
  1;
}

sub timeout { $_[0]->{timeout} = $_[1] }

sub get { shift->_do('GET',@_) }
sub delete { shift->_do('DELETE',@_) }
sub put { shift->_do('PUT',@_) }
sub post { shift->_do('POST',@_) }

sub _do {
  my $self = shift;
  my ($rq, $url, @args) = @_;
  use experimental qw/smartmatch/;
#  if (length($self->{_user}) && length($self->{_pwd})) {
#    $url =~ s|(https?://)|${1}$$self{_user}:$$self{_pwd}@|;
#  }
#  $DB::single = 1 if $url =~ /Roger/;
  $url =~ s{/([^/]+)}{'/'.uri_escape_utf8($1,$unsafe)}ge;
  my ($resp,$content,$content_file);
  given ($rq) {
    when (/get|delete/i) {
      $resp = $self->request(uc $rq, $url);
    }
    when (/post|put/i) {
      my @rm;
      for my $i (0..$#args) {
	given ($args[$i]) {
	  when ('Content') {
	    $content = $args[$i+1];
	    push @rm, $i, $i+1;
	  }
	  when (':content_file') {
	    $content_file = $args[$i+1];
	    push @rm, $i, $i+1;
	  }
	  default {
	    1;
	  }
	}
      }
      delete @args[@rm];
      my %options;
      if (@args) {
	my %args = @args;
	$options{headers} = \%args;
      }

      $options{content} = $content if $content;
      if (defined $content_file) {
	open my $cfh,">", $content_file or die "content file : $!";
	$options{data_callback} = sub { $cfh->write($_[0], length ($_[0])) };
      }
      $resp = $self->request(uc $rq, $url, \%options);
    }
    default {
      REST::Neo4p::NotImplException->throw("Method $rq not implemented in ".__PACKAGE__."\n");
    }
  }
  if ($resp->code == 599) {
    given( $resp->content ) {
      when (/timeout/) {
	$resp->code(500);
	$resp->message("Connection timeout");
      }
      default {
	1;
      }
    }
  }
  return $resp;
}

1;