DBD::Gofer::Transport::http - DBD::Gofer client transport using http

  my $remote_dsn = "..."
  DBI->connect("dbi:Gofer:transport=http;url=http://gofer.example.com/gofer;dsn=$remote_dsn",...)

  export DBI_AUTOPROXY='dbi:Gofer:transport=http;url=http://gofer.example.com/gofer'

  $response = $transport->transmit_request_by_transport( $request );

  $retry = $transport->response_retry_preference($request, $response);

  $transport->discard_cached_connections();

package DBD::Gofer::Transport::http;

#   $Id: http.pm 11766 2008-09-12 12:23:47Z timbo $
#
#   Copyright (c) 2007, Tim Bunce, Ireland
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.

use strict;
use warnings;

our $VERSION = 1.017; # keep in sync with Makefile.PL

use Carp;
use URI;
use LWP::UserAgent;
use HTTP::Request;

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";
}


sub response_retry_preference {
    my $self = shift;
    my ($request, $response) = @_;

    my $response_meta = $response->meta;
    my $http_status = $response_meta->{http_status} || 0;
    if ($http_status == 503) {
        # we assume for 503 that the request has not been executed
        # so we don't check if $request->is_idempotent
        return sub {
            my $request_meta = $request->meta;
            # delay before retry, with exponential backoff
            my $delay = (($request_meta->{retry_delay} ||= $RETRY_DELAY_INIT) *= $RETRY_BACKOFF_SCALE);
            my $msg = "Gofer delaying $delay seconds before retry after $http_status error\n";
            ($RETRY_WARN) ? warn($msg) : $self->trace_msg($msg);
            select(undef, undef, undef, $delay);
            return;
        };
    }

    return $self->SUPER::response_retry_preference(@_);
}


1;

__END__