promises-retry-test.pl

use strict;
use Mojo::Promise;
use Mojo::UserAgent;
use DDP;

my $ua = Mojo::UserAgent->new->with_roles('+Queued')->inactivity_timeout(1);
my $max_fail_num = 100;

my $results_count = {};
my @retry_pos = (0, 0.5, 1, 2, 4, 5, 10, 20, 25, 30, 40);

$_ = $_ / 100 for @retry_pos;    # Test only!

sub _exp_retry_fail {
    my $x = shift;
    my $t = $retry_pos[$x] || $retry_pos[-1];
    print "Retry N=$x T=$t\n";
    return $t;
}

sub _success_cb {
    my ($insistent_promises, $url, $fail_count) = @_;

    $fail_count ||= 0;

    return sub {
        my ($tx) = @_;

        $results_count->{x}{$url}{$tx->res->code}++;

        use DDP;
        p $fail_count;


        if ($tx->res->code == 200) {
            $insistent_promises->resolve($tx->res);
        }
        else {

            $fail_count++;

            my $exp_retry = &_exp_retry_fail($fail_count);

            if ($fail_count < $max_fail_num) {

                Mojo::IOLoop->timer(
                    $exp_retry => sub {
                        $ua->get_p($tx->req->url->to_abs)
                          ->then(
                            _success_cb($insistent_promises, $url, $fail_count))
                          ->catch(
                            _fail_cb($insistent_promises, $url, $fail_count));
                    }
                );

            }
            else {

                $insistent_promises->reject("Too many errors on $url");
            }

        }
      }
}

sub _fail_cb {
    my ($insistent_promises, $url, $fail_count) = @_;

    $fail_count ||= 0;

    return sub {
        my ($err) = @_;
        p ['_fail_cb', $err];

        $results_count->{x}{$url}{'timeout'}++;

        my $exp_retry = &_exp_retry_fail($fail_count);

        $fail_count++;
        if ($fail_count < $max_fail_num) {

            Mojo::IOLoop->timer(
                $exp_retry => sub {
                    $ua->get_p($url)
                      ->then(
                        _success_cb($insistent_promises, $url, $fail_count))
                      ->catch(_fail_cb($insistent_promises, $url, $fail_count));
                }
            );
        }
        else {

            $insistent_promises->reject('Too many conections fails', $url);
        }
    };

}

my %current_p;
my $errored;

my $pid = 0;
for my $num (1 .. 20) {

    my $insistent_promises = Mojo::Promise->new;
    $pid++;
    $current_p{$pid} = $insistent_promises;

    my $url = 'http://localhost:3000/maybe_fail?num=' . $num;

    $ua->get_p($url)->then(&_success_cb($insistent_promises, $url, 0))
      ->catch(_fail_cb($insistent_promises, $url, 0));


    $insistent_promises->then(
        sub {
            my ($res) = @_;
            $results_count->{p}{$res->json->{num}}{$res->code}++;
        }
      )->catch(
        sub {
            print STDERR "cancel everythiiiiiiiiiiing!!!\n\n\n";

            $errored++;
            Mojo::Promise->reset;
        }
      )->finally(sub {
        delete $current_p{$pid};
    });

    Mojo::Promise->all($insistent_promises);
}

Mojo::Promise->all(values %current_p)->wait;

if ($errored) {
    die "Please do not commit!!!\n";
}

p $results_count;
exit;

# I tried this but did not worked:

my $is_done = 0
  ; # TODO check if queue is empty, because it may never return run the event if not!
$ua->on(
    queue_empty => sub {

        use DDP;
        p "on is queue_empty!";
        $is_done = 1;
    }
);

while (1) {

    Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
    Mojo::IOLoop->next_tick(
        sub {

            if (!$is_done) {
                Mojo::IOLoop->stop;
            }
        }
    );
}

# this never run
p $results_count;
    

results.txt

perl lost-and-found/promises-retry-test.pl 

Printing in line 32 of lost-and-found/promises-retry-test.pl:
0
Retry N=1 T=0.005
Printing in line 32 of lost-and-found/promises-retry-test.pl:
0
Retry N=1 T=0.005.

...

Printing in line 140 of lost-and-found/promises-retry-test.pl:
{
    p:  {
        1 :  {
            200:  1
        },
        2 :  {
            200:  1
        },
        3 :  {
            200:  1
        },
        4 :  {
            200:  1
        },
        5 :  {
            200:  1
        },
        6 :  {
            200:  1
        },
        7 :  {
            200:  1
        },
        8 :  {
            200:  1
        },
        9 :  {
            200:  1
        },
        10:  {
            200:  1
        },
        11:  {
            200:  1
        },
        12:  {
            200:  1
        },
        13:  {
            200:  1
        },
        14:  {
            200:  1
        },
        15:  {
            200:  1
        },
        16:  {
            200:  1
        },
        17:  {
            200:  1
        },
        18:  {
            200:  1
        },
        19:  {
            200:  1
        },
        20:  {
            200:  1
        }
    },
    x:  {
        http://localhost:3000/maybe_fail?num=1 :  {
            200:  1,
            400:  5
        },
        http://localhost:3000/maybe_fail?num=2 :  {
            200    :  1,
            400    :  10,
            timeout:  1
        },
        http://localhost:3000/maybe_fail?num=3 :  {
            200:  1,
            400:  2
        },
        http://localhost:3000/maybe_fail?num=4 :  {
            200    :  1,
            400    :  6,
            timeout:  1
        },
        http://localhost:3000/maybe_fail?num=5 :  {
            200    :  1,
            400    :  12,
            timeout:  1
        },
        http://localhost:3000/maybe_fail?num=6 :  {
            200:  1,
            400:  3
        },
        http://localhost:3000/maybe_fail?num=7 :  {
            200:  1,
            400:  5
        },
        http://localhost:3000/maybe_fail?num=8 :  {
            200    :  1,
            400    :  1,
            timeout:  1
        },
        http://localhost:3000/maybe_fail?num=9 :  {
            200:  1,
            400:  5
        },
        http://localhost:3000/maybe_fail?num=10:  {
            200:  1
        },
        http://localhost:3000/maybe_fail?num=11:  {
            200:  1
        },
        http://localhost:3000/maybe_fail?num=12:  {
            200    :  1,
            400    :  3,
            timeout:  1
        },
        http://localhost:3000/maybe_fail?num=13:  {
            200:  1
        },
        http://localhost:3000/maybe_fail?num=14:  {
            200    :  1,
            400    :  8,
            timeout:  1
        },
        http://localhost:3000/maybe_fail?num=15:  {
            200:  1
        },
        http://localhost:3000/maybe_fail?num=16:  {
            200    :  1,
            400    :  10,
            timeout:  3
        },
        http://localhost:3000/maybe_fail?num=17:  {
            200    :  1,
            400    :  7,
            timeout:  1
        },
        http://localhost:3000/maybe_fail?num=18:  {
            200    :  1,
            400    :  22,
            timeout:  1
        },
        http://localhost:3000/maybe_fail?num=19:  {
            200:  1,
            400:  1
        },
        http://localhost:3000/maybe_fail?num=20:  {
            200    :  1,
            400    :  4,
            timeout:  3
        }
    }
}

webserver.pl

get '/maybe_fail' => sub {
    my $c = shift;

    my $status = rand > 0.8 ? 200 : 400;

    if (rand > 0.95 ){
        $c->render_later; # sometimes do timeouts
        return;
    }

    $c->render(json => {num => $c->req->param('num'),}, status => $status,);
};

new version with Race (5 at a time), maybe with_roles('+Queued') is not needed!
https://gist.github.com/renatocron/190f9a4efb92df8bd386650d4088e9dc