File Coverage

blib/lib/Mojo/UserAgent/Role/Retry.pm

Criterion	Covered	Total	%
statement	27	28	96.4
branch	13	14	92.8
condition	4	5	80.0
subroutine	5	5	100.0
pod			n/a
total	49	52	94.2

package Mojo::UserAgent::Role::Retry 0.003;

# ABSTRACT: Retry requests on failure

use Mojo::Base -role;

use HTTP::Date qw(str2time);


use constant DEBUG => $ENV{MOJO_CLIENT_DEBUG} || 0;

my $_TX_ROLE_RETRY = "Mojo::Transaction::HTTP::Role::Retry";


has retries        => 5;
has retry_wait_min => 1;
has retry_wait_max => 20;
has retry_policy   => sub {
  return sub {
    my $tx = shift;

    my $err = $tx->error;
    if (!$err) { return 1; }

    my $code = $err->{code};
    if (!$code) { return 0; }

    if ($code == 429 || $code == 503) { return 0; }

    return 1;
  };
};

around build_tx => sub {
  my ( $orig, $self, @args ) = @_;
  return $self->$orig(@args)->with_roles($_TX_ROLE_RETRY)->retries(0);
};

around start => sub {
  my ( $orig, $self, $tx, $cb ) = @_;

  if ( !eval { $tx->does($_TX_ROLE_RETRY) } ) {
    return $self->$orig( $tx, $cb );
  }

  if ( $tx->retries > 0 ) {
    my $remaining = $self->retries - $tx->retries;
    warn "-- Remaining retries: $remaining" if DEBUG;
  }

  if ( !$cb ) {
    $tx = $self->$orig($tx);
    if ( $self->retry_policy->($tx) )     { return $tx; }
    if ( $tx->retries >= $self->retries ) { return $tx; }
    sleep $self->_retry_wait_time($tx);
    my $new_tx = Mojo::Transaction::HTTP->with_roles($_TX_ROLE_RETRY)
      ->new->req( $tx->req->clone )->retries( $tx->retries + 1 );
    return $self->start( $new_tx, $cb );
  }

  return $self->$orig(
    $tx => sub {
      my ( $ua, $tx ) = @_;
      if ( $self->retry_policy->($tx) )     { return $cb->( $ua, $tx ); }
      if ( $tx->retries >= $self->retries ) { return $cb->( $ua, $tx ); }
      Mojo::IOLoop->timer(
        $self->_retry_wait_time($tx) => sub {
          my $new_tx = Mojo::Transaction::HTTP->with_roles($_TX_ROLE_RETRY)
            ->new->req( $tx->req->clone )->retries( $tx->retries + 1 );
          return $self->start( $new_tx, $cb );
        }
      );
    }
  );
};

sub _retry_wait_time {
  my ( $self, $tx ) = @_;
  my $wait = $self->retry_wait_min;
  if ( my $retry_after = $tx->res->headers->header('Retry-After') ) {
    $wait = _parse_retry_after($retry_after);
    if    ( $wait == 0 )                    { $wait = $self->retry_wait_min; }
    elsif ( $wait > $self->retry_wait_max ) { $wait = $self->retry_wait_max; }
  }
  return $wait;
}

sub _parse_retry_after {
  my $v = shift;
  if ( !defined $v )             { return 0; }
  if ( $v =~ /^\d+$/ && $v > 0 ) { return $v; }
  my $date = str2time($v);
  if ( !$date )       { return 0; }
  if ( $date < time ) { return 0; }
  return $date - time;
}

1;

__END__