File Coverage

blib/lib/DBIx/Connector/Retry.pm

Criterion	Covered	Total	%
statement	57	64	89.0
branch	14	18	77.7
condition			n/a
subroutine	11	14	78.5
pod	2	3	66.6
total	84	99	84.8

package DBIx::Connector::Retry;

our $AUTHORITY = 'cpan:GSG';
# ABSTRACT: DBIx::Connector with block retry support
use version;
our $VERSION = 'v0.900.1'; # VERSION

use strict;
use warnings;

use Moo;

extends 'DBIx::Connector', 'Moo::Object';

use Scalar::Util           qw( weaken );
use Types::Standard        qw( Str Bool HashRef CodeRef Dict Tuple Optional Maybe );
use Types::Common::Numeric qw( PositiveInt );

use namespace::clean;  # don't export the above

#pod =encoding utf8
#pod
#pod =head1 SYNOPSIS
#pod
#pod     my $conn = DBIx::Connector::Retry->new(
#pod         connect_info  => [ 'dbi:Driver:database=foobar', $user, $pass, \%args ],
#pod         retry_debug   => 1,
#pod         max_attempts  => 5,
#pod     );
#pod
#pod     # Keep retrying/reconnecting on errors
#pod     my ($count) = $conn->run(ping => sub {
#pod         $_->do('UPDATE foobar SET updated = 1 WHERE active = ?', undef, 'on');
#pod         $_->selectrow_array('SELECT COUNT(*) FROM foobar WHERE updated = 1');
#pod     });
#pod
#pod     # Add a simple retry_handler for a manual timeout
#pod     my $start_time = time;
#pod     $conn->retry_handler(sub { time <= $start_time + 60 });
#pod
#pod     my ($count) = $conn->txn(fixup => sub {
#pod         $_->selectrow_array('SELECT COUNT(*) FROM barbaz');
#pod     });
#pod     $conn->clear_retry_handler;
#pod
#pod     # Plus everything else in DBIx::Connector
#pod
#pod =head1 DESCRIPTION
#pod
#pod DBIx::Connector::Retry is a Moo-based subclass of L that will retry on
#pod failures.  Most of the interface was modeled after L
#pod and adapted for use in DBIx::Connector.
#pod
#pod =head1 ATTRIBUTES
#pod
#pod =head2 connect_info
#pod
#pod An arrayref that contains all of the connection details normally found in the L or
#pod L call.  This data can be changed, but won't take effect until the next
#pod C<$dbh> re-connection cycle.
#pod
#pod Obviously, this is required.
#pod
#pod =cut

has connect_info => (
    is       => 'rw',
    # Yes, DBI->connect() is still technically-valid syntax
    isa      => Tuple[ Maybe[Str], Maybe[Str], Maybe[Str], Optional[HashRef] ],
    required => 1,
);

#pod =head2 mode
#pod
#pod This is just like L except that it can be set from within the
#pod constructor.
#pod
#pod Unlike DBIx::Connector, the default is C, not C.
#pod
#pod =cut

has _mode => (
    is       => 'bare',  # use DBIx::Connector's accessor
    isa      => Str,
    init_arg => 'mode',
    required => 0,
    default  => 'ping',
);

#pod =head2 disconnect_on_destroy
#pod
#pod This is just like L except that it can be set
#pod from within the constructor.
#pod
#pod Default is on.
#pod
#pod =cut

has _dond => (
    is       => 'bare',  # use DBIx::Connector's accessor
    isa      => Bool,
    init_arg => 'disconnect_on_destroy',
    required => 0,
    default  => 1,
);

#pod =head2 max_attempts
#pod
#pod The maximum amount of block running attempts before the Connector gives up and dies.
#pod
#pod Default is 10.
#pod
#pod =cut

has max_attempts => (
    is       => 'rw',
    isa      => PositiveInt,
    required => 0,
    default  => 10,
);

#pod =head2 retry_debug
#pod
#pod If enabled, any retries will output a debug warning with the error message and number
#pod of retries.
#pod
#pod =cut

has retry_debug => (
    is       => 'rw',
    isa      => Bool,
    required => 0,
    default  => 0,
    lazy     => 1,
);

#pod =head2 retry_handler
#pod
#pod An optional handler that will be checked on each retry.  It will be passed the Connector
#pod object as its only input.  If the handler returns a true value, retries will continue.
#pod A false value will cause the retry loop to immediately rethrow the exception.  You can
#pod also throw your own, if you prefer.
#pod
#pod This check is independent of checks for L.
#pod
#pod The last exception can be inspected as part of the check by looking at L.
#pod This is recommended to make sure the failure is actually what you expect it to be.
#pod For example:
#pod
#pod     $conn->retry_handler(sub {
#pod         my $c = shift;
#pod         my $err = $c->last_exception;
#pod         $err = $err->error if blessed $err && $err->isa('DBIx::Connector::RollbackError');
#pod
#pod         $err =~ /deadlock|timeout/i;  # only retry on deadlocks or timeouts
#pod     });
#pod
#pod Default is an always-true coderef.
#pod
#pod This attribute has the following handles:
#pod
#pod =head3 clear_retry_handler
#pod
#pod Sets it back to the always-true default.
#pod
#pod =cut

has retry_handler => (
    is       => 'rw',
    isa      => CodeRef,
    required => 1,
    default  => sub { sub { 1 } },
);

sub clear_retry_handler { shift->retry_handler(sub { 1 }) }

#pod =head2 failed_attempt_count
#pod
#pod The number of failed attempts so far.  This can be used in the L or
#pod checked afterwards.  It will be reset on each block run.
#pod
#pod Not available for initialization.
#pod
#pod =cut

has failed_attempt_count => (
    is       => 'ro',
    init_arg => undef,
    writer   => '_set_failed_attempt_count',
    default  => 0,
    lazy     => 1,
    trigger  => sub {
        my ($self, $val) = @_;
        die sprintf (
            'Reached max_attempts amount of %d, latest exception: %s',
            $self->max_attempts, $self->last_exception
        ) if $self->max_attempts <= ( $val || 0 );
    },
);

#pod =head2 exception_stack
#pod
#pod The stack of exceptions received so far, as an arrayref.  This can be used in the
#pod L or checked afterwards.  It will be reset on each block run.
#pod
#pod Not available for initialization.
#pod
#pod This attribute has the following handles:
#pod
#pod =head3 last_exception
#pod
#pod The last exception on the stack.
#pod
#pod =cut

has exception_stack => (
    is       => 'ro',
    init_arg => undef,
    clearer  => '_reset_exception_stack',
    default  => sub { [] },
    lazy     => 1,
);

sub last_exception { shift->exception_stack->[-1] }

#pod =head1 CONSTRUCTORS
#pod
#pod =head2 new
#pod
#pod     my $conn = DBIx::Connector::Retry->new(
#pod         connect_info => [ 'dbi:Driver:database=foobar', $user, $pass, \%args ],
#pod         max_attempts => 5,
#pod         # ...etc...
#pod     );
#pod
#pod     # Old-DBI syntax
#pod     my $conn = DBIx::Connector::Retry->new(
#pod         'dbi:Driver:database=foobar', $user, $pass, \%dbi_args,
#pod         max_attempts => 5,
#pod         # ...etc...
#pod     );
#pod
#pod As this is a L class, it uses the standard Moo constructor.  The L
#pod should be specified as its own key.  The L/L syntax is available,
#pod but only as a nicety for compatibility.
#pod
#pod =cut

around BUILDARGS => sub {
    my ($orig, $class, @args) = @_;

    # Old-style DBI/DBIx::Connector parameters.  Try to fix it up.
    if (@args && $args[0] && !ref $args[0] && $args[0] =~ /^dbi:/) {
        my @connect_info = splice(@args, 0, 3);                                       # DBI DSN, UN, PW
        push @connect_info, shift @args if $args[0] && (ref $args[0]||'') eq 'HASH';  # DBI \%attr, if it exists

        if ( @args && $args[0] && (my $ref = ref $args[0]) ) {
            if    ($ref eq 'ARRAY') {
                push @{$args[0]}, ( connect_info => \@connect_info );
                @args = @{$args[0]};  # Moo::Object::BUILDARGS doesn't actually support lone ARRAYREFs
            }
            elsif ($ref eq 'HASH') {
                $args[0]{connect_info} = \@connect_info;
            }
            else {
                # Mimicing Moo::Object::BUILDARGS here
                Carp::croak(join ' ',
                    "The new() method for $class cannot parse the strange argument list.",
                    "Please switch to a standard Moo constructor, instead of the DBI syntax.",
                );
            }
        }
        else {
            # either the key within a list or we're out of arguments
            push @args, ( connect_info => \@connect_info );
        }
    }

    return $class->$orig(@args);
};

sub BUILD {
    my ($self, $args) = @_;

    my @connect_args = @{ $self->connect_info };

    # Add in the keys that DBIx::Connector expects.  For the purposes of future
    # expandability of DBIx::Connector, we do this by getting a new base Connector
    # object, and inject those properties into our own object.

    my $base_obj = DBIx::Connector->new(@connect_args);
    %$self = (
        %$base_obj,
        %$self,  # $self's existing attributes take priority
    );

    # DBIx::Connector stores connection details in a coderef (for some reason).  Instead
    # of just dumping the same arguments as another copy, we'll tie it directly to the
    # attr.  If connect_info ever changes, it will grab the latest version.
    $self->{_args} = sub { @{ $self->connect_info } };
    weaken $self;  # circular closure ref
}

#pod =head1 MODIFIED METHODS
#pod
#pod =head2 run / txn
#pod
#pod     my @result = $conn->run($mode => $coderef);
#pod     my $result = $conn->run($mode => $coderef);
#pod     $conn->run($mode => $coderef);
#pod
#pod     my @result = $conn->txn($mode => $coderef);
#pod     my $result = $conn->txn($mode => $coderef);
#pod     $conn->txn($mode => $coderef);
#pod
#pod Both L and L are modified to run inside
#pod a retry loop.  If the original Connector action dies, the exception is caught, and if
#pod L and L allows it, the action is retried.  The database
#pod handle may be reset by the Connector action, according to its connection mode.
#pod
#pod See L for important behaviors/limitations.
#pod
#pod =cut

foreach my $method (qw< run txn >) {
    around $method => sub {
        my $orig = shift;
        my $self = shift;
        my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift;
        my $cref = shift;

        my $wantarray = wantarray;

        return $self->_retry_loop($orig, $method, $mode, $cref, $wantarray);
    };
}

sub _retry_loop {
    my ($self, $orig, $method, $mode, $cref, $wantarray) = @_;

    $self->_reset_exception_stack;
    $self->_set_failed_attempt_count(0);

    # If we already started in a transaction, that implies nesting, so don't
    # retry the query.  We can't guarantee that the statements before the block
    # run will be committed, and are assuming that the connection will break.
    #
    # We cannot rely on checking the database connection via ping, because some
    # DBDs (like mysql) will try to reconnect to the DB if the first ping check
    # fails, and a reconnection auto-rollbacks all transactions, locks, etc.
    if ($self->in_txn) {
        unless (defined $wantarray) { return        $self->$orig($mode, $cref)  }
        elsif          ($wantarray) { return       ($self->$orig($mode, $cref)) }
        else                        { return scalar $self->$orig($mode, $cref)  }
    }

    # Mode is localized within $orig, but we should localize it again ourselves, in case
    # it's changed on-the-fly.
    local $self->{_mode} = $mode;

    my $run_err;
    my @res;

    do {
        TRY: {
            local $@;
            eval {
                unless (defined $wantarray) {           $self->$orig($mode, $cref) }
                elsif          ($wantarray) { @res    = $self->$orig($mode, $cref) }
                else                        { $res[0] = $self->$orig($mode, $cref) }
            };
            $run_err = $@;
        }

        if ($run_err) {
            push @{ $self->exception_stack }, $run_err;

            # This will throw if max_attempts is reached
            $self->_set_failed_attempt_count($self->failed_attempt_count + 1);

            # If the retry handler says no, then die
            die $run_err unless $self->retry_handler->($self);

            # Debug line
            warn sprintf(
                'Retrying %s coderef (attempt %d) after caught exception: %s',
                $method,
                $self->failed_attempt_count + 1,
                $run_err,
            ) if $self->retry_debug;
        }
    } while ($run_err);

    return $wantarray ? @res : $res[0];
}

#pod =head1 CAVEATS
#pod
#pod =head2 $dbh settings
#pod
#pod Like L, it's important that the L properties have sane
#pod connection settings.
#pod
#pod L should be turned on.  Otherwise, the connection is
#pod considered to be already in a transaction, and no retries will be attempted.  Instead,
#pod use transactions via L.
#pod
#pod L should also be turned on, since exceptions are captured,
#pod and both Retry and Connector use them to determine if any of the C<$dbh> calls failed.
#pod
#pod =head2 Savepoints and nested transactions
#pod
#pod L is NOT modified to work inside of a retry loop,
#pod because retries are generally not possible for savepoints, and a disconnected connection
#pod will rollback any uncommited statements in most RDBMS.  The same goes for any C/C
#pod calls attempted inside of a transaction.
#pod
#pod Consider the following:
#pod
#pod     # If this dies, sub will retry
#pod     $conn->txn(ping => sub {
#pod         shift->do('UPDATE foobar SET updated = 1 WHERE active = ?', undef, 'on');
#pod
#pod         # If this dies, it will not retry
#pod         $conn->svp(sub {
#pod             my $c = shift;
#pod             $c->do('INSERT foobar (name, updated, active) VALUES (?, ?)', undef, 'barbaz', 0, 'off');
#pod         });
#pod     });
#pod
#pod If the savepoint actually tried to retry, the C statement would get rolled back by
#pod virtue of database disconnection.  However, the savepoint code would continue, possibly
#pod even succeeding.  You would never know that the C statement was rolled back.
#pod
#pod However, without savepoint retry support, as it is currently designed, the statements
#pod will work as expected.  If the savepoint code dies, and if C<$conn> is set up for
#pod retries, the transaction code is restarted, after a rollback or reconnection.  Thus, the
#pod C and C statements are both ran properly if they now succeed.
#pod
#pod Obviously, this will not work if transactions are manually started outside of the main
#pod Connector interface:
#pod
#pod     # Don't do this!  The whole transaction isn't compartmentalized properly!
#pod     $conn->run(ping => sub {
#pod         $_->begin_work;  # don't ever call this!
#pod         $_->do('UPDATE foobar SET updated = 1 WHERE active = ?', undef, 'on');
#pod     });
#pod
#pod     # If this dies, the whole app will probably crash
#pod     $conn->svp(sub {
#pod         my $c = shift;
#pod         $c->do('INSERT foobar (name, updated, active) VALUES (?, ?)', undef, 'barbaz', 0, 'off');
#pod     });
#pod
#pod     # Don't do this!
#pod     $conn->run(ping => sub {
#pod         $_->commit;  # no, let Connector handle this process!
#pod     });
#pod
#pod =head2 Fixup mode
#pod
#pod Because of the nature of L, the block may be
#pod executed twice as often.  Functionally, the code looks like this:
#pod
#pod     # Very simplified example
#pod     sub fixup_run {
#pod         my ($self, $code) = @_;
#pod
#pod         my (@ret, $run_err);
#pod         do {
#pod             eval {
#pod                 @ret = eval { $code->($dbh) };
#pod                 my $err = $@;
#pod
#pod                 if ($err) {
#pod                     die $err if $self->connected;
#pod                     # Not connected. Try again.
#pod                     return $code->($dbh);
#pod                 }
#pod             };
#pod             $run_err = $@;
#pod
#pod             if ($run_err) {
#pod                 # Push exception_stack, set/check attempts, check retry_handler
#pod             }
#pod         } while ($run_err);
#pod         return @ret;
#pod     }
#pod
#pod If the first eval dies because of a connection failure, the code is ran twice before the
#pod retry loop finds it.  This is only considered to be one attempt.  If it dies because of
#pod some other fault, it's only ran once and continues the retry loop.
#pod
#pod If this is behavior is undesirable, this can be worked around by using the L
#pod to change the L after the first attempt:
#pod
#pod     $conn->retry_handler(sub {
#pod         my $c = shift;
#pod         $c->mode('ping') if $c->mode eq 'fixup';
#pod         1;
#pod     });
#pod
#pod Mode is localized outside of the retry loop, so even C<< $conn->run(fixup => $code) >>
#pod calls work, and the default mode will return to normal after the block run.
#pod
#pod =head1 SEE ALSO
#pod
#pod L, L
#pod
#pod =cut

1;

__END__