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__

=head1 NAME
    
DBD::Gofer::Transport::http - DBD::Gofer client transport using http

=head1 SYNOPSIS

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

or, enable by setting the DBI_AUTOPROXY environment variable:

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

which will force I<all> DBI connections to be made via that Gofer server.

=head1 DESCRIPTION

Connect with DBI::Gofer servers that use http transports, i.e., L<DBI::Gofer::Transport::mod_perl>.

This module currently uses the L<LWP::UserAgent> and L<HTTP::Request> modules to manage the http protocol.
The default timeout is undef (unlimited). The LWP::UserAgent C<env_proxy> option is enabled.

=head1 ATTRIBUTES

See L<DBD::Gofer::Transport::Base> for a description of the Gofer transport
attributes that are common to all transports, and another common features such
as enabling gofer transport tracing.

The DBD::Gofer::Transport::http transport doesn't add any extra attributes.

=head2 go_timeout

The timeout provided by L<DBD::Gofer::Transport::Base> is used.
The C<go_timeout> value is also passed to LWP::UserAgent as its timeout value.
In practice the DBD::Gofer::Transport::Base timeout would almost certainly fire first.
This area is subject to change in future releases.

=head1 PROTOCOL

The request is sent as a POST with a content type of 'C<application/x-perl-gofer-request-binary>'.

The user-agent string is 'C<DBD::Gofer::Transport::http/><$DBI::VERSION>C</><$VERSION>'.

=head1 METHODS

=head2 transmit_request_by_transport

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

Freezes and transmits the request using the L<LWP::UserAgent> and L<HTTP::Request> modules.
Waits for and returns response. Any exception is caught and returned as a response object.

=head2 receive_response_by_transport

This method isn't used because transmit_request_by_transport() always returns a response object.
If called it throws an exception.

=head2 response_retry_preference

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

The response_retry_preference is called by DBD::Gofer when considering if a
request should be retried after an error.

Returns true (would like to retry), false (must not retry), undef (no preference).

If a true value is returned in the form of a CODE ref then, if DBD::Gofer does
decide to retry the request, it calls the code ref passing $retry_count, $retry_limit.
Currently the called code must return using C<return;>.

=head2 discard_cached_connections

  $transport->discard_cached_connections();

Drops any persistent-connections associated with the transport.

=head1 ENVIRONMENT VARIABLES

These environment variables are not considered a stable part of the interface
and they may change between releases. (The general plan is for corresponding
gofer transport attributes to be added. That would enable per-handle
configuration. Patches welcome.)

=head2 DBD_GOFER_CONN_CACHE

Specifies the size of the persistent-conection cache for the transport object.
Default is 10. Set to 0 to disable use of HTTP/1.1 persistent-conections.

=head2 DBD_GOFER_RETRY_WARN

Emit a warn() whenever a request is retried.

=head2 DBD_GOFER_RETRY_BACKOFF_SCALE

Specifies the amount to multiply the retry delay by on each retry.
Default value 2.

=head2 DBD_GOFER_RETRY_DELAY_INIT

Initial delay, in seconds, before retrying after a request receives a 503
response. (The DBD_GOFER_RETRY_BACKOFF_SCALE is applied first, so the actual
initial delay is this value multipled by DBD_GOFER_RETRY_BACKOFF_SCALE).
Default value 0.2.

=head2 DBD_GOFER_RETRY_ON_EMPTY

Used to workaround problems with buggy load balancers (e.g. a Juniper DX with
standing connections enabled) which cause some requests to fail whithout ever
reaching the gofer server.

If set to 1 then empty responses will be retried. If is_idempotent() is true
then upto 20 retries will be performed, else just 1 retry. The retries happen
without any delay and log a warning each time.

If set to a higher value then the retry counts are multiplied by that amount,
so a value of 3 will retry idempotent requests 30 times, for example.

This mechanism is not recommended for non-readonly databases because there's a
risk that the server did receive and act on the request, so retrying it would
cause the database change to be repeated, which may cause other problems.

=head1 BUGS AND LIMITATIONS

There is currently no support for http authentication.

Please report any bugs or feature requests to
C<bug-dbi-gofer-transport-mod_perl@rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org>.

=head1 SEE ALSO

L<DBD::Gofer> and L<DBI::Gofer::Transport::mod_perl>

=head1 AUTHOR

Tim Bunce, L<http://www.tim.bunce.name>

=head1 LICENCE AND COPYRIGHT

Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.

=cut