Skip to content

Commit a444c97

Browse files
kraihkraih
committed
Add download methods to Mojo::UserAgent and Mojo::UserAgent::Transactor
1 parent bd690df commit a444c97

File tree

5 files changed

+307
-0
lines changed

5 files changed

+307
-0
lines changed

‎lib/Mojo/UserAgent.pm‎

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ use Mojo::Base 'Mojo::EventEmitter';
33

44
# "Fry: Since when is the Internet about robbing people of their privacy?
55
# Bender: August 6, 1991."
6+
use Carp qw(croak);
67
use Mojo::IOLoop;
78
use Mojo::Promise;
89
use Mojo::Util qw(monkey_patch term_escape);
@@ -48,6 +49,22 @@ sub DESTROY { shift->_cleanup unless ${^GLOBAL_PHASE} eq 'DESTRUCT' }
4849
sub build_tx { shift->transactor->tx(@_) }
4950
sub build_websocket_tx { shift->transactor->websocket(@_) }
5051

52+
sub download {
53+
my ($self, $url, $path, $options) = (shift, shift, shift, shift // {});
54+
55+
my $tx = _download_error($self->transactor->download($self->head($url => $options->{headers} // {}), $path));
56+
return $tx ? !!_download_error($self->start($tx)) : 1;
57+
}
58+
59+
sub download_p {
60+
my ($self, $url, $path, $options) = (shift, shift, shift, shift // {});
61+
62+
return $self->head_p($url => $options->{headers} // {})->then(sub {
63+
my $tx = _download_error($self->transactor->download(shift, $path));
64+
return $tx ? $self->start_p($tx) : 1;
65+
})->then(sub { ref $_[0] ? !!_download_error($_[0]) : $_[0] });
66+
}
67+
5168
sub start {
5269
my ($self, $tx, $cb) = @_;
5370

@@ -213,6 +230,15 @@ sub _dequeue {
213230
return $found;
214231
}
215232

233+
sub _download_error {
234+
my $tx = shift;
235+
236+
return $tx unless my $err = $tx->error;
237+
return undef if $err->{message} eq 'Download complete' || $err->{message} eq 'Download incomplete';
238+
croak "$err->{code} response: $err->{message}" if $err->{code};
239+
croak "Download error: $err->{message}";
240+
}
241+
216242
sub _error {
217243
my ($self, $id, $err) = @_;
218244
my $tx = $self->{connections}{$id}{tx};
@@ -748,6 +774,27 @@ a callback.
748774
warn "Connection error: $err";
749775
})->wait;
750776
777+
=head2 download
778+
779+
my $bool = $ua->download('https://example.com/test.tar.gz', '/home/sri/test.tar.gz');
780+
my $bool = $ua->download('https://example.com/test.tar.gz', '/home/sri/test.tar.gz', {headers => {Accept => '*/*'}});
781+
782+
Download file from URL to local file, returns true once the file has been downloaded completely. Incomplete downloads
783+
are resumed. Note that this method is B<EXPERIMENTAL> and might change without warning!
784+
785+
=head2 download_p
786+
787+
my $promise = $ua->download_p('https://example.com/test.tar.gz', '/home/sri/test.tar.gz');
788+
789+
Same as L</"download">, but performs all requests non-blocking and returns a L<Mojo::Promise> object. Note that this
790+
method is B<EXPERIMENTAL> and might change without warning!
791+
792+
$ua->download_p('https://example.com/test.tar.gz', '/home/sri/test.tar.gz')->then(sub ($finished) {
793+
say $finished ? 'Download finished' : 'Download was interrupted';
794+
})->catch(sub ($err) {
795+
warn $err;
796+
})->wait;
797+
751798
=head2 get
752799
753800
my $tx = $ua->get('example.com');

‎lib/Mojo/UserAgent/Transactor.pm‎

Lines changed: 49 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
package Mojo::UserAgent::Transactor;
22
use Mojo::Base -base;
33

4+
use Carp qw(croak);
45
use Mojo::Asset::File;
56
use Mojo::Asset::Memory;
67
use Mojo::Content::MultiPart;
@@ -20,6 +21,47 @@ has name => 'Mojolicious (Perl)';
2021

2122
sub add_generator { $_[0]->generators->{$_[1]} = $_[2] and return $_[0] }
2223

24+
sub download {
25+
my ($self, $head, $path) = @_;
26+
27+
my $req = $head->req;
28+
my $tx = $self->tx(GET => $req->url->clone => $req->headers->to_hash);
29+
my $res = $tx->res;
30+
if (my $error = $head->error) { $res->error($error) and return $tx }
31+
32+
my $headers = $head->res->headers;
33+
my $accept_ranges = ($headers->accept_ranges // '') =~ /bytes/;
34+
my $size = $headers->content_length // 0;
35+
36+
my $current_size = 0;
37+
my $file = path($path);
38+
if (-f $file) {
39+
$current_size = -s $file;
40+
$res->error({message => 'Unknown file size'}) and return $tx unless $size;
41+
$res->error({message => 'File size mismatch'}) and return $tx if $current_size > $size;
42+
$res->error({message => 'Download complete'}) and return $tx if $current_size == $size;
43+
$res->error({message => 'Server does not support partial requests'}) and return $tx unless $accept_ranges;
44+
$tx->req->headers->range("bytes=$current_size-$size");
45+
}
46+
47+
my $fh = $file->open('>>');
48+
$res->content->unsubscribe('read')->on(
49+
read => sub {
50+
my ($content, $bytes) = @_;
51+
$current_size += length $bytes;
52+
$fh->syswrite($bytes) == length $bytes or $res->error({message => qq/Can't write to file "$path": $!/});
53+
}
54+
);
55+
$res->on(
56+
finish => sub {
57+
my $res = shift;
58+
$res->error({message => 'Download incomplete'}) if $current_size < $size;
59+
}
60+
);
61+
62+
return $tx;
63+
}
64+
2365
sub endpoint {
2466
my ($self, $tx) = @_;
2567

@@ -371,6 +413,13 @@ Register a content generator.
371413
372414
$t->add_generator(foo => sub ($t, $tx, @args) {...});
373415
416+
=head2 download
417+
418+
my $tx = $t->download(Mojo::Transaction::HTTP->new, '/home/sri/test.tar.gz');
419+
420+
Build L<Mojo::Transaction::HTTP> resumable file download request as follow-up to a C<HEAD> request. Note that this
421+
method is B<EXPERIMENTAL> and might change without warning!
422+
374423
=head2 endpoint
375424
376425
my ($proto, $host, $port) = $t->endpoint(Mojo::Transaction::HTTP->new);

‎lib/Mojolicious/Guides/Cookbook.pod‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1300,6 +1300,15 @@ L<Mojo::Message/"save_to">.
13001300
my $tx = $ua->get('https://www.github.com/mojolicious/mojo/tarball/main');
13011301
$tx->result->save_to('mojo.tar.gz');
13021302

1303+
With L<Mojo::UserAgent/"download"> you can also stream file downloads directly into the target file. This also allows
1304+
for interrupted downloads to be resumed at a later time.
1305+
1306+
use Mojo::UserAgent;
1307+
1308+
# Download the latest Mojolicious tarball directly into a file
1309+
my $ua = Mojo::UserAgent->new(max_redirects => 5);
1310+
$ua->download('https://www.github.com/mojolicious/mojo/tarball/main' => '/home/sri/mojo.tar.gz');
1311+
13031312
To protect you from excessively large files there is also a limit of 2GiB by default, which you can tweak with the
13041313
attribute L<Mojo::UserAgent/"max_response_size">.
13051314

‎t/mojo/transactor.t‎

Lines changed: 85 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,8 @@ use Mojo::Base -strict;
33
use Test::More;
44
use Mojo::Asset::File;
55
use Mojo::Asset::Memory;
6+
use Mojo;
7+
use Mojo::File qw(tempdir);
68
use Mojo::Promise;
79
use Mojo::Transaction::WebSocket;
810
use Mojo::URL;
@@ -1016,6 +1018,89 @@ subtest '301 redirect without compression' => sub {
10161018
is $tx->res->headers->location, undef, 'no "Location" value';
10171019
};
10181020

1021+
subtest 'Download' => sub {
1022+
my $dir = tempdir;
1023+
my $no_file = $dir->child('no_file');
1024+
my $small_file = $dir->child('small_file')->spew('x');
1025+
my $large_file = $dir->child('large_file')->spew('xxxxxxxxxxx');
1026+
my $correct_file = $dir->child('correct_file')->spew('xxxxxxxxxx');
1027+
my $t = Mojo::UserAgent::Transactor->new;
1028+
1029+
subtest 'Partial file exists' => sub {
1030+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz');
1031+
$head->res->headers->content_length(10);
1032+
$head->res->headers->accept_ranges('bytes');
1033+
my $tx = $t->download($head, $small_file);
1034+
is $tx->req->method, 'GET', 'right method';
1035+
is $tx->req->url->to_abs, 'http://mojolicious.org/release.tar.gz', 'right URL';
1036+
is $tx->req->headers->range, 'bytes=1-10', 'right "Range" value';
1037+
};
1038+
1039+
subtest 'Partial file exists (with headers)' => sub {
1040+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz' => {Accept => 'application/json'});
1041+
$head->res->headers->content_length(10);
1042+
$head->res->headers->accept_ranges('bytes');
1043+
my $tx = $t->download($head, $small_file);
1044+
is $tx->req->method, 'GET', 'right method';
1045+
is $tx->req->url->to_abs, 'http://mojolicious.org/release.tar.gz', 'right URL';
1046+
is $tx->req->headers->range, 'bytes=1-10', 'right "Range" value';
1047+
is $tx->req->headers->accept, 'application/json', 'right "Accept" value';
1048+
};
1049+
1050+
subtest 'Failed HEAD request' => sub {
1051+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz');
1052+
$head->res->error({message => 'Failed to connect'});
1053+
my $tx = $t->download($head, $no_file);
1054+
is $tx->error->{message}, 'Failed to connect', 'right error';
1055+
};
1056+
1057+
subtest 'Empty HEAD response' => sub {
1058+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz');
1059+
my $tx = $t->download($head, $no_file);
1060+
is $tx->req->method, 'GET', 'right method';
1061+
is $tx->req->url->to_abs, 'http://mojolicious.org/release.tar.gz', 'right URL';
1062+
is $tx->req->headers->range, undef, 'no "Range" value';
1063+
};
1064+
1065+
subtest 'Empty HEAD response (file exists)' => sub {
1066+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz');
1067+
my $tx = $t->download($head, $small_file);
1068+
is $tx->error->{message}, 'Unknown file size', 'right error';
1069+
};
1070+
1071+
subtest 'Target file does not exist' => sub {
1072+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz');
1073+
$head->res->headers->content_length(10);
1074+
my $tx = $t->download($head, $no_file);
1075+
is $tx->req->method, 'GET', 'right method';
1076+
is $tx->req->url->to_abs, 'http://mojolicious.org/release.tar.gz', 'right URL';
1077+
is $tx->req->headers->range, undef, 'no "Range" value';
1078+
};
1079+
1080+
subtest 'Partial file exists (unsupported server)' => sub {
1081+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz');
1082+
$head->res->headers->content_length(10);
1083+
my $tx = $t->download($head, $small_file);
1084+
is $tx->error->{message}, 'Server does not support partial requests', 'right error';
1085+
};
1086+
1087+
subtest 'Partial file exists (larger than download)' => sub {
1088+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz');
1089+
$head->res->headers->content_length(10);
1090+
$head->res->headers->accept_ranges('bytes');
1091+
my $tx = $t->download($head, $large_file);
1092+
is $tx->error->{message}, 'File size mismatch', 'right error';
1093+
};
1094+
1095+
subtest 'Download already finished' => sub {
1096+
my $head = $t->tx(HEAD => 'http://mojolicious.org/release.tar.gz');
1097+
$head->res->headers->content_length(10);
1098+
$head->res->headers->accept_ranges('bytes');
1099+
my $tx = $t->download($head, $correct_file);
1100+
is $tx->error->{message}, 'Download complete', 'right error';
1101+
};
1102+
};
1103+
10191104
subtest 'Promisify' => sub {
10201105
my $promise = Mojo::Promise->new;
10211106
my (@results, @errors);

‎t/mojo/user_agent_download.t‎

Lines changed: 117 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,117 @@
1+
use Mojo::Base -strict;
2+
3+
BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' }
4+
5+
use Test::More;
6+
use Mojo::File qw(tempdir);
7+
use Mojo::UserAgent;
8+
use Mojolicious::Lite;
9+
10+
# Silence
11+
app->log->level('trace')->unsubscribe('message');
12+
13+
get '/test1' => sub {
14+
my $c = shift;
15+
$c->res->headers->accept_ranges('bytes');
16+
return $c->render(data => 'CHUNK1CHUNK2CHUNK3');
17+
};
18+
19+
get '/test2' => sub {
20+
my $c = shift;
21+
$c->res->headers->accept_ranges('bytes');
22+
return $c->render(data => 'CHUNK1CHUNK2CHUNK3') if $c->req->method eq 'HEAD';
23+
my $range = $c->req->headers->range;
24+
return $c->write('CHUNK1')->finish unless $range;
25+
return $c->write('CHUNK2')->finish if $range eq 'bytes=6-18';
26+
return $c->write('CHUNK3')->finish;
27+
};
28+
29+
get '/test4' => sub {
30+
my $c = shift;
31+
my $chunks = [qw(CHUNK1 CHUNK2 CHUNK3 CHUNK4)];
32+
$c->res->code(200);
33+
$c->res->headers->content_type('text/plain');
34+
my $cb = sub {
35+
my $content = shift;
36+
my $chunk = shift @$chunks || '';
37+
$content->write_chunk($chunk, $chunk ? __SUB__ : undef);
38+
};
39+
$c->res->content->$cb;
40+
$c->rendered;
41+
};
42+
43+
my $dir = tempdir;
44+
my $ua = Mojo::UserAgent->new;
45+
46+
subtest 'Basic file download' => sub {
47+
my $file = $dir->child('test1a.txt');
48+
ok $ua->download('/test1', $file), 'file downloaded';
49+
ok -e $file, 'file exists';
50+
is $file->slurp, 'CHUNK1CHUNK2CHUNK3', 'right content';
51+
};
52+
53+
subtest 'File already downloaded' => sub {
54+
my $file = $dir->child('test1a.txt');
55+
is $file->slurp, 'CHUNK1CHUNK2CHUNK3', 'right content';
56+
ok $ua->download('/test1', $file), 'file downloaded';
57+
is $file->slurp, 'CHUNK1CHUNK2CHUNK3', 'right content';
58+
};
59+
60+
subtest 'Basic file download (non-blocking)' => sub {
61+
my $file = $dir->child('test1b.txt');
62+
my $result;
63+
$ua->download_p('/test1', $file)->then(sub { $result = shift })->wait;
64+
ok $result, 'file downloaded';
65+
ok -e $file, 'file exists';
66+
is $file->slurp, 'CHUNK1CHUNK2CHUNK3', 'right content';
67+
};
68+
69+
subtest 'Exsiting file is larger' => sub {
70+
my $file = $dir->child('test1c.txt')->spew('CHUNK1CHUNK2CHUNK3CHUNK4');
71+
eval { $ua->download('/test1', $file) };
72+
like $@, qr/Download error: File size mismatch/, 'right error';
73+
};
74+
75+
subtest 'Resumed file download' => sub {
76+
my $file = $dir->child('test2a.txt');
77+
ok !$ua->download('/test2', $file), 'file partially downloaded';
78+
ok !$ua->download('/test2', $file), 'file continued';
79+
ok $ua->download('/test2', $file), 'file downloaded';
80+
ok -e $file, 'file exists';
81+
is $file->slurp, 'CHUNK1CHUNK2CHUNK3', 'right content';
82+
};
83+
84+
subtest 'Missing file' => sub {
85+
my $file = $dir->child('test3a.txt');
86+
eval { $ua->download('/test3', $file) };
87+
like $@, qr/404 response: Not Found/, 'file not found';
88+
};
89+
90+
subtest 'Missing file (non-blocking)' => sub {
91+
my $file = $dir->child('test3b.txt');
92+
my $err;
93+
$ua->download_p('/test3', $file)->catch(sub { $err = shift })->wait;
94+
like $err, qr/404 response: Not Found/, 'file not found';
95+
};
96+
97+
subtest 'File of unknown size' => sub {
98+
my $file = $dir->child('test4a.txt')->spew('C');
99+
eval { $ua->download('/test4', $file) };
100+
like $@, qr/Download error: Unknown file size/, 'right error';
101+
};
102+
103+
subtest 'File of unknown size (non-blocking)' => sub {
104+
my $file = $dir->child('test4b.txt')->spew('C');
105+
my $err;
106+
$ua->download_p('/test4', $file)->catch(sub { $err = shift })->wait;
107+
like $err, qr/Download error: Unknown file size/, 'right error';
108+
};
109+
110+
subtest 'File of unknown size downloaded' => sub {
111+
my $file = $dir->child('test4c.txt');
112+
ok $ua->download('/test4', $file), 'file downloaded';
113+
ok -e $file, 'file exists';
114+
is $file->slurp, 'CHUNK1CHUNK2CHUNK3CHUNK4', 'right content';
115+
};
116+
117+
done_testing();

0 commit comments

Comments
 (0)