File Coverage

blib/lib/Mojo/UserAgent/Role/Resume.pm
Criterion Covered Total %
statement 14 25 56.0
branch 0 14 0.0
condition 0 5 0.0
subroutine 5 7 71.4
pod 0 1 0.0
total 19 52 36.5


line stmt bran cond sub pod time code
1             package Mojo::UserAgent::Role::Resume;
2 1     1   851 use 5.016;
  1         4  
3 1     1   5 use strict;
  1         2  
  1         20  
4 1     1   5 use warnings;
  1         1  
  1         32  
5              
6 1     1   531 use Mojo::Base -role;
  1         194558  
  1         9  
7              
8 1     1   510 use Scalar::Util 'refaddr';
  1         3  
  1         1376  
9              
10             our $VERSION = "v0.0.4";
11              
12             has max_attempts => 1;
13              
14             my $TX_ROLE = "Mojo::Transaction::HTTP::Role::Resume";
15              
16             # only add the role to HTTP requests, and not to websockets
17             around build_tx => sub {
18             my ($orig, $self, @args) = @_;
19              
20             my $tx = $self->$orig(@args)->with_roles($TX_ROLE);
21             return $tx->_RESUME_original_arguments(\@args);
22             };
23              
24             around start => sub {
25             my ($orig, $self, @args) = @_;
26              
27             my ($orig_tx, @orig_cb) = @args;
28             my $orig_cb = $orig_cb[0];
29             my $blocking = !defined $orig_cb;
30              
31             # don't wrap this 'start' invocation, if websocket, redirect, or retry
32             return $self->$orig(@args)
33             if !eval{$orig_tx->does($TX_ROLE)} or $orig_tx->previous or $orig_tx->RESUME_previous_attempt;
34              
35             my $tx = $orig_tx; # $tx will always equal the first tx (ie before any redirections) of every attempt
36             my @original_build_args = @{ $tx->_RESUME_original_arguments() };
37             my $server_is_crappy_for_ranges = 0; # has server been proven to be unreliable for ranged requests?
38             my $latest_good_200_tx; # the last tx with code 200 & full headers (holds the asset that 206 tx's should append to)
39             my $remaining_attempts = $self->max_attempts;
40              
41             # prevent ref cycles (which could lead to memory leaks)
42             my $_clean = sub {
43             undef $_ foreach ($tx, $latest_good_200_tx);
44             undef @original_build_args;
45             };
46              
47             # set special my_progress event handler to $tx, and also to the retries:
48             my $progress_handler = sub {
49             my ($msg) = @_;
50              
51             # my_progress handlers are by default only executed on 200|206 responses
52             return unless $msg->code and $msg->code =~ /^20(0|6)$/;
53             return unless $msg->headers->is_finished;
54              
55             # only run once
56             $msg->unsubscribe(progress => __SUB__);
57              
58             my $total_size = _total_size($msg);
59              
60             !$server_is_crappy_for_ranges or return; # only interested if server was not labelled crappy
61              
62             my $headers = $msg->headers;
63             my $old_headers = eval {$latest_good_200_tx->res->headers};
64             my ($h_start_byte) = ($headers->content_range // '') =~ /^bytes (\d+)\-/;
65              
66             $server_is_crappy_for_ranges ||= do {
67             # 1. missing all important headers
68             (!$headers->etag and !$headers->last_modified and !defined $total_size) or
69              
70             # 2. wrong HTTP status code:
71             ($tx->req->headers->range xor $msg->code == 206) or
72              
73             # 3. missing, malformed, or extra Content-Range header:
74             ($msg->code == 200 and $headers->content_range) or
75             ($msg->code == 206 and ($headers->content_range // '') !~ /^bytes \d+\-\d+\/(\*|\d+)$/) or
76              
77             # 4. an important header is different than that of the older tx that we are resuming on:
78             (defined $old_headers and (
79             !eqq($headers->etag, $old_headers->etag) or
80             !eqq($headers->last_modified, $old_headers->last_modified) or
81             !eqq($total_size, _total_size($latest_good_200_tx->res))
82             )) or
83              
84             # 5. the numbers in the headers don't add-up correctly
85             ($msg->code == 206 and (
86             !defined $h_start_byte or
87             !eqq($h_start_byte, scalar(eval {$latest_good_200_tx->res->content->asset->size})) or
88             (defined $total_size and defined $headers->content_length
89             and $h_start_byte + $headers->content_length != $total_size)
90             ));
91             };
92              
93             if ($msg->code == 206) {
94             if ($server_is_crappy_for_ranges) {
95             # abort and retry
96             $remaining_attempts++; # just this one attempt should be "for free", since it was inexpensive
97             $msg->error({ message => "web server can't handle ranged requests, aborting" }); # abort
98             return;
99             } else {
100             # switch asset
101             my $big_asset = $latest_good_200_tx->res->content->asset->add_chunk($msg->content->asset->slurp);
102             $msg->content->asset($big_asset);
103             }
104             } elsif ($msg->code == 200) {
105             if (!$server_is_crappy_for_ranges) {
106             # mark as latest good tx:
107             $latest_good_200_tx = $tx;
108             }
109             }
110             };
111             unshift @{ $tx->res->subscribers('progress') }, $progress_handler;
112              
113             my $build_retry_tx = sub {
114             my ($old_tx) = @_;
115              
116             # don't continue if $old_tx isn't a failure
117             return undef unless $old_tx->error and !$old_tx->res->is_client_error;
118              
119             # TODO: Check whether we should also check for "content received < total_size_based_on_headers"
120              
121             my $retry_tx = $self->build_tx(@original_build_args);
122             unshift @{ $retry_tx->res->subscribers('progress') }, $progress_handler;
123              
124             if ($latest_good_200_tx and !$server_is_crappy_for_ranges) {
125             # set Range: header
126             $retry_tx->req->headers->range('bytes='.$latest_good_200_tx->res->content->asset->size.'-');
127             }
128              
129             # store old_tx in a field of new_tx, similar to $tx->previous for redirects
130             $retry_tx->RESUME_previous_attempt($old_tx); # store old tx in $retry_tx
131              
132             return $retry_tx;
133             };
134              
135             # don't start any transactions if $remaining_attempts is not high enough
136             $remaining_attempts >= 1 or return $tx;
137              
138             if ($blocking) {
139             my $tx_after_redirects;
140             while (1) {
141             $tx_after_redirects = $self->$orig($tx, @orig_cb);
142             --$remaining_attempts >= 1 and $tx = $build_retry_tx->($tx_after_redirects) or last;
143             }
144             $_clean->();
145             return $tx_after_redirects;
146             } else {
147             return $self->$orig($tx, sub {
148             my ($ua, $tx_after_redirects) = @_;
149             --$remaining_attempts >= 1 and $tx = $build_retry_tx->($tx_after_redirects)
150             or $_clean->(), $orig_cb->($ua, $tx_after_redirects), return;
151             $ua->$orig($tx, __SUB__);
152             });
153             }
154             };
155              
156             sub eqq {
157 0     0 0   my ($x, $y) = @_;
158              
159 0 0         defined $x or return !defined $y;
160 0 0         defined $y or return !!0;
161 0 0         ref $x eq ref $y or return !!0;
162 0 0         return length(ref $x) ? refaddr $x == refaddr $y : $x eq $y;
163             }
164              
165             sub _total_size {
166 0     0     my ($msg) = @_;
167              
168 0 0         return undef unless $msg->headers->is_finished;
169              
170 0 0         if ($msg->code == 206) {
171 0   0       ($msg->headers->content_range // '') =~ /^bytes \d+\-(\d+)\/(?:\*|(\d+))\z/;
172 0 0 0       return $2 // (defined $1 ? $1 + 1 : undef);
173             } else {
174 0           return $msg->headers->content_length;
175             }
176             }
177              
178             1;
179             __END__