view release on metacpan or  search on metacpan

lib/DBD/Gofer/Transport/http.pm  view on Meta::CPAN

use DBI 1.55;
use base qw(DBD::Gofer::Transport::Base);

# set $DBI::stderr if unset (ie for older versions of DBI)
$DBI::stderr ||= 2_000_000_000;

__PACKAGE__->mk_accessors(qw(
    http_req
    http_ua
)); 

# (XXX All this rety logic should move into core gofer transport base classes)
# INitial delay is actually scaled by RETRY_BACKOFF_SCALE first
our $RETRY_DELAY_INIT     = $ENV{DBD_GOFER_RETRY_DELAY_INIT}    || 0.2;
our $RETRY_BACKOFF_SCALE  = $ENV{DBD_GOFER_RETRY_BACKOFF_SCALE} || 2;
our $RETRY_ON_EMPTY_SCALE = $ENV{DBD_GOFER_RETRY_ON_EMPTY}      || 0;
our $RETRY_WARN           = $ENV{DBD_GOFER_RETRY_WARN}          || 1;

our $CONN_CACHE = $ENV{DBD_GOFER_CONN_CACHE}; # set to 0 to disable
# default to 10, though as the cache is per transport object it'll probably
# never have more than one connection in it.
$CONN_CACHE = 10 unless defined $CONN_CACHE;


sub discard_cached_connections { # custom method for http transport
    my $self = shift;
    my $http_ua = $self->{http_ua} or return;
    my $conn_cache = $http_ua->conn_cache or return;
    #my $pre = $conn_cache->get_connections;
    $conn_cache->drop;
    #warn "discard_cached_connections $pre->".$conn_cache->get_connections;
    return;
}


sub transmit_request_by_transport {
    my ($self, $request) = @_;

    my $retry_on_empty_response = 0;
    if ($RETRY_ON_EMPTY_SCALE) {
        $retry_on_empty_response = ($request->is_idempotent) ? 10 : 1;
        $retry_on_empty_response *= $RETRY_ON_EMPTY_SCALE; # scalaing factor
    }

    my $response = eval { 
        my $frozen_request = $self->freeze_request($request);

        my $http_req = $self->{http_req} ||= do {
            my $url = $self->go_url || croak "No url specified";
            my $request = HTTP::Request->new(POST => $url);
            $request->content_type('application/x-perl-gofer-request-binary');
            $request;
        };
        my $http_ua = $self->{http_ua} ||= do {
            my $useragent = LWP::UserAgent->new(
                timeout => $self->go_timeout,   # undef by default
                keep_alive => $CONN_CACHE, # sets total_capacity of LWP::ConnCache
                env_proxy => 1, # XXX
            );
            $useragent->agent(join "/", __PACKAGE__, $DBI::VERSION, $VERSION);
            #$useragent->credentials( $netloc, $realm, $uname, $pass ); XXX
            $useragent->parse_head(0); # don't parse html head
            $useragent;
        };

        my $content = $frozen_request;
        $http_req->header('Content-Length' => do { use bytes; length($content) } );
        $http_req->content($content);

        # Pass request to the user agent and get a response back
	SEND_REQUEST:
        my $res = $http_ua->request($http_req);

        my $frozen_response = $res->content;

        if (not $res->is_success or not $frozen_response) {
	    my $code = $res->code;
	    my $msg  = $res->message;

	    if (!$frozen_response && $res->is_success) {
		# fake an error status - Net::HTTP should have done this
		# but LWP::Protocol::http calls read_response_headers with laxed=>1
		# so old versions treat this as a valid 'HTTP/0.9' response.
		$code = 500;
		$msg  = "Server returned empty response";
	    }

	    if ($code == 500
	    && $msg =~ m/^Server (closed connection without sending|returned empty response)/
	    && $retry_on_empty_response-- > 0
	    ) {
		my $msg = "$code $msg from ".$self->go_url;
		warn "$msg ($retry_on_empty_response retry left)\n" if $RETRY_WARN;
		goto SEND_REQUEST;
	    }

            return DBI::Gofer::Response->new({
                err    => $DBI::stderr + $code,
                errstr => "$code $msg",
                meta => {   # extra info for response_needs_retransmit (below)
                    http_status => $code,
                    http_response => $res,
                }
            }); 
        }

        return $self->thaw_response($frozen_response);
    };
    $response ||= DBI::Gofer::Response->new({ err => $DBI::stderr, errstr => $@||'(no response)' });
    return $response;
}


sub receive_response_by_transport {
    my $self = shift;
    # transmit_request_by_transport does all the work for this driver
    # so receive_response_by_transport should never be called
    croak "receive_response_by_transport should never be called";
}