File Coverage

blib/lib/Mojo/UserAgent/Transactor.pm
Criterion Covered Total %
statement 194 194 100.0
branch 104 110 94.5
condition 59 66 89.3
subroutine 30 30 100.0
pod 9 9 100.0
total 396 409 96.8


line stmt bran cond sub pod time code
1             package Mojo::UserAgent::Transactor;
2 55     55   944 use Mojo::Base -base;
  55         154  
  55         472  
3              
4 55     55   458 use Mojo::Asset::File;
  55         181  
  55         719  
5 55     55   333 use Mojo::Asset::Memory;
  55         196  
  55         502  
6 55     55   341 use Mojo::Content::MultiPart;
  55         166  
  55         710  
7 55     55   435 use Mojo::Content::Single;
  55         167  
  55         592  
8 55     55   380 use Mojo::File qw(path);
  55         170  
  55         3432  
9 55     55   402 use Mojo::JSON qw(encode_json);
  55         213  
  55         3092  
10 55     55   423 use Mojo::Parameters;
  55         177  
  55         481  
11 55     55   26602 use Mojo::Transaction::HTTP;
  55         200  
  55         548  
12 55     55   441 use Mojo::Transaction::WebSocket;
  55         199  
  55         366  
13 55     55   299 use Mojo::URL;
  55         165  
  55         351  
14 55     55   309 use Mojo::Util qw(encode url_escape);
  55         165  
  55         3247  
15 55     55   417 use Mojo::WebSocket qw(challenge client_handshake);
  55         151  
  55         179765  
16              
17             has compressed => sub { $ENV{MOJO_GZIP} // 1 };
18             has generators => sub { {form => \&_form, json => \&_json, multipart => \&_multipart} };
19             has name => 'Mojolicious (Perl)';
20              
21 1 50   1 1 15 sub add_generator { $_[0]->generators->{$_[1]} = $_[2] and return $_[0] }
22              
23             sub endpoint {
24 2048     2048 1 4376 my ($self, $tx) = @_;
25              
26             # Basic endpoint
27 2048         5272 my $req = $tx->req;
28 2048         5667 my $url = $req->url;
29 2048   50     6781 my $proto = $url->protocol || 'http';
30 2048         5945 my $host = $url->ihost;
31 2048 100 66     5677 my $port = $url->port // ($proto eq 'https' ? 443 : 80);
32              
33             # Proxy for normal HTTP requests
34 2048         3420 my $socks;
35 2048 100       5267 if (my $proxy = $req->proxy) { $socks = $proxy->protocol eq 'socks' }
  64         151  
36 2048 100 100     8219 return _proxy($tx, $proto, $host, $port) if $proto eq 'http' && !$req->is_handshake && !$socks;
      100        
37              
38 181         1048 return $proto, $host, $port;
39             }
40              
41 214     214 1 814 sub peer { _proxy($_[1], $_[0]->endpoint($_[1])) }
42              
43             sub promisify {
44 47     47 1 175 my ($self, $promise, $tx) = @_;
45 47         197 my $err = $tx->error;
46 47 100 100     267 return $promise->reject($err->{message}) if $err && !$err->{code};
47 43 100 100     123 return $promise->reject('WebSocket handshake failed') if $tx->req->is_handshake && !$tx->is_websocket;
48 41         186 $promise->resolve($tx);
49             }
50              
51             sub proxy_connect {
52 191     191 1 579 my ($self, $old) = @_;
53              
54             # Already a CONNECT request
55 191         613 my $req = $old->req;
56 191 100       693 return undef if uc $req->method eq 'CONNECT';
57              
58             # No proxy
59 187 100 100     637 return undef unless (my $proxy = $req->proxy) && $req->via_proxy;
60 7 100       34 return undef if $proxy->protocol eq 'socks';
61              
62             # WebSocket and/or HTTPS
63 5         16 my $url = $req->url;
64 5 100 100     20 return undef unless $req->is_handshake || $url->protocol eq 'https';
65              
66             # CONNECT request (expect a bad response)
67 3         17 my $new = $self->tx(CONNECT => $url->clone->userinfo(undef));
68 3         250 $new->req->proxy($proxy);
69 3         15 $new->res->content->auto_relax(0)->headers->connection('keep-alive');
70              
71 3         23 return $new;
72             }
73              
74             sub redirect {
75 917     917 1 2106 my ($self, $old) = @_;
76              
77             # Commonly used codes
78 917         2415 my $res = $old->res;
79 917   100     2457 my $code = $res->code // 0;
80 917 100       2480 return undef unless grep { $_ == $code } 301, 302, 303, 307, 308;
  4585         13382  
81              
82             # CONNECT requests cannot be redirected
83 54         160 my $req = $old->req;
84 54 100       185 return undef if uc $req->method eq 'CONNECT';
85              
86             # Fix location without authority and/or scheme
87 53 50       177 return undef unless my $location = $res->headers->every_header('Location')->[0];
88 53         202 $location = Mojo::URL->new($location);
89 53 100       171 $location = $location->base($req->url)->to_abs unless $location->is_abs;
90 53         197 my $proto = $location->protocol;
91 53 100 100     294 return undef if ($proto ne 'http' && $proto ne 'https') || !$location->host;
      100        
92              
93             # Clone request if necessary
94 51         187 my $new = Mojo::Transaction::HTTP->new;
95 51 100 100     274 if ($code == 307 || $code == 308) {
96 10 100       53 return undef unless my $clone = $req->clone;
97 8         31 $new->req($clone);
98             }
99             else {
100 41         227 my $method = uc $req->method;
101 41 100 100     215 $method = $code == 303 || $method eq 'POST' ? 'GET' : $method;
102 41         139 $new->req->method($method)->content->headers(my $headers = $req->headers->clone);
103 41         89 $headers->remove($_) for grep {/^content-/i} @{$headers->names};
  147         450  
  41         107  
104             }
105              
106 49 100       190 $new->res->content->auto_decompress(0) unless $self->compressed;
107 49         146 my $headers = $new->req->url($location)->headers;
108 49         225 $headers->remove($_) for qw(Authorization Cookie Host Referer);
109              
110 49         233 return $new->previous($old);
111             }
112              
113             sub tx {
114 1042     1042 1 173327 my ($self, $method, $url) = (shift, shift, shift);
115              
116             # Method and URL
117 1042         5212 my $tx = Mojo::Transaction::HTTP->new;
118 1042         3653 my $req = $tx->req->method($method);
119 1042 100       4299 ref $url ? $req->url($url) : $req->url->parse($url =~ m!^/|://! ? $url : "http://$url");
    100          
120              
121             # Headers (we identify ourselves and accept gzip compression)
122 1042         3932 my $headers = $req->headers;
123 1042 100       4353 $headers->from_hash(shift) if ref $_[0] eq 'HASH';
124 1042 100       3625 $headers->user_agent($self->name) unless $headers->user_agent;
125 1042 100       3811 if (!$self->compressed) { $tx->res->content->auto_decompress(0) }
  3 50       16  
126 1039         2656 elsif (!$headers->accept_encoding) { $headers->accept_encoding('gzip') }
127              
128             # Generator
129 1042 100       4113 if (@_ > 1) {
    100          
130 83         374 my $cb = $self->generators->{shift()};
131 83         303 $self->$cb($tx, @_);
132             }
133              
134             # Body
135 25         163 elsif (@_) { $req->body(shift) }
136              
137 1042         4900 return $tx;
138             }
139              
140             sub upgrade {
141 956     956 1 2486 my ($self, $tx) = @_;
142 956   100     2466 my $code = $tx->res->code // 0;
143 956 100 100     2817 return undef unless $tx->req->is_handshake && $code == 101;
144 63         462 my $ws = Mojo::Transaction::WebSocket->new(handshake => $tx, masked => 1);
145 63 50       267 return challenge($ws) ? $ws->established(1) : undef;
146             }
147              
148             sub websocket {
149 80     80 1 23918 my $self = shift;
150              
151             # New WebSocket transaction
152 80 100       320 my $sub = ref $_[-1] eq 'ARRAY' ? pop : [];
153 80         301 my $tx = $self->tx(GET => @_);
154 80         261 my $req = $tx->req;
155 80 100       261 $req->headers->sec_websocket_protocol(join ', ', @$sub) if @$sub;
156              
157             # Handshake protocol
158 80         242 my $url = $req->url;
159 80   50     359 my $proto = $url->protocol // '';
160 80 100       471 if ($proto eq 'ws') { $url->scheme('http') }
  7 100       26  
    100          
161 5         15 elsif ($proto eq 'wss') { $url->scheme('https') }
162 1         4 elsif ($proto eq 'ws+unix') { $url->scheme('http+unix') }
163              
164 80         313 return client_handshake $tx;
165             }
166              
167 31     31   218 sub _content { Mojo::Content::MultiPart->new(headers => $_[0], parts => $_[1]) }
168              
169             sub _form {
170 66     66   209 my ($self, $tx, $form, %options) = @_;
171 66 100       281 $options{charset} = 'UTF-8' unless exists $options{charset};
172              
173             # Check for uploads and force multipart if necessary
174 66         215 my $req = $tx->req;
175 66         244 my $headers = $req->headers;
176 66   100     288 my $multipart = ($headers->content_type // '') =~ m!multipart/form-data!i;
177 66 100       270 for my $value (map { ref $_ eq 'ARRAY' ? @$_ : $_ } values %$form) {
  104         411  
178 108 100 50     358 ++$multipart and last if ref $value eq 'HASH';
179             }
180              
181             # Multipart
182 66 100       227 if ($multipart) {
183 27         152 $req->content(_content($headers, _form_parts($options{charset}, $form)));
184 27         137 _type($headers, 'multipart/form-data');
185 27         118 return $tx;
186             }
187              
188             # Query parameters or urlencoded
189 39         133 my $method = uc $req->method;
190 39         158 my @form = map { $_ => $form->{$_} } sort keys %$form;
  63         214  
191 39 100 100     243 if ($method eq 'GET' || $method eq 'HEAD') { $req->url->query->merge(@form) }
  7         32  
192             else {
193 32         172 $req->body(Mojo::Parameters->new(@form)->charset($options{charset})->to_string);
194 32         266 _type($headers, 'application/x-www-form-urlencoded');
195             }
196              
197 39         148 return $tx;
198             }
199              
200             sub _form_parts {
201 27     27   94 my ($charset, $form) = @_;
202              
203 27         59 my @parts;
204 27         108 for my $name (sort keys %$form) {
205 41 100       137 next unless defined(my $values = $form->{$name});
206 40 100       155 $values = [$values] unless ref $values eq 'ARRAY';
207 40         76 push @parts, @{_parts($charset, $name, $values)};
  40         132  
208             }
209              
210 27         135 return \@parts;
211             }
212              
213             sub _json {
214 11     11   37 my ($self, $tx, $data) = @_;
215 11         44 _type($tx->req->body(encode_json $data)->headers, 'application/json');
216 11         36 return $tx;
217             }
218              
219             sub _multipart {
220 4     4   11 my ($self, $tx, $parts) = @_;
221 4         11 my $req = $tx->req;
222 4         16 $req->content(_content($req->headers, _parts(undef, undef, $parts)));
223 4         24 return $tx;
224             }
225              
226             sub _parts {
227 44     44   120 my ($charset, $name, $values) = @_;
228              
229 44         70 my @parts;
230 44         96 for my $value (@$values) {
231 55         199 push @parts, my $part = Mojo::Content::Single->new;
232              
233 55         139 my $filename;
234 55         169 my $headers = $part->headers;
235 55 100       277 if (ref $value eq 'HASH') {
236              
237             # File
238 30 100       170 if (my $file = delete $value->{file}) {
    50          
239 9 100       88 $file = Mojo::Asset::File->new(path => $file) unless ref $file;
240 9         37 $part->asset($file);
241 9 100 66     143 $value->{filename} //= path($file->path)->basename if $file->isa('Mojo::Asset::File');
242             }
243              
244             # Memory
245             elsif (defined(my $content = delete $value->{content})) {
246 21         88 $part->asset(Mojo::Asset::Memory->new->add_chunk($content));
247             }
248              
249             # Filename and headers
250 30         105 $filename = delete $value->{filename};
251 30         143 $headers->from_hash($value);
252 30 100       81 next unless defined $name;
253 26   66     139 $filename = url_escape $filename // $name, '"';
254 26 50       142 $filename = encode $charset, $filename if $charset;
255             }
256              
257             # Field
258             else {
259 25 100       130 $value = encode $charset, $value if $charset;
260 25         111 $part->asset(Mojo::Asset::Memory->new->add_chunk($value));
261             }
262              
263             # Content-Disposition
264 51 100 100     573 next if !defined $name || defined $headers->content_disposition;
265 48         181 $name = url_escape $name, '"';
266 48 100       227 $name = encode $charset, $name if $charset;
267 48         178 my $disposition = qq{form-data; name="$name"};
268 48 100       162 $disposition .= qq{; filename="$filename"} if defined $filename;
269 48         134 $headers->content_disposition($disposition);
270             }
271              
272 44         213 return \@parts;
273             }
274              
275             sub _proxy {
276 2081     2081   5958 my ($tx, $proto, $host, $port) = @_;
277              
278 2081         5109 my $req = $tx->req;
279 2081 100 100     5976 if ($req->via_proxy && (my $proxy = $req->proxy)) {
280 51 100 66     152 return $proxy->protocol, $proxy->ihost, $proxy->port // ($proto eq 'https' ? 443 : 80);
281             }
282              
283 2030         12724 return $proto, $host, $port;
284             }
285              
286 70 100   70   257 sub _type { $_[0]->content_type($_[1]) unless $_[0]->content_type }
287              
288             1;
289              
290             =encoding utf8
291              
292             =head1 NAME
293              
294             Mojo::UserAgent::Transactor - User agent transactor
295              
296             =head1 SYNOPSIS
297              
298             use Mojo::UserAgent::Transactor;
299              
300             # GET request with Accept header
301             my $t = Mojo::UserAgent::Transactor->new;
302             say $t->tx(GET => 'http://example.com' => {Accept => '*/*'})->req->to_string;
303              
304             # POST request with form-data
305             say $t->tx(POST => 'example.com' => form => {a => 'b'})->req->to_string;
306              
307             # PUT request with JSON data
308             say $t->tx(PUT => 'example.com' => json => {a => 'b'})->req->to_string;
309              
310             =head1 DESCRIPTION
311              
312             L is the transaction building and manipulation framework used by L.
313              
314             =head1 GENERATORS
315              
316             These content generators are available by default.
317              
318             =head2 form
319              
320             $t->tx(POST => 'http://example.com' => form => {a => 'b'});
321              
322             Generate query string, C or C content. See L for more.
323              
324             =head2 json
325              
326             $t->tx(PATCH => 'http://example.com' => json => {a => 'b'});
327              
328             Generate JSON content with L. See L for more.
329              
330             =head2 multipart
331              
332             $t->tx(PUT => 'http://example.com' => multipart => ['Hello', 'World!']);
333              
334             Generate multipart content. See L for more.
335              
336             =head1 ATTRIBUTES
337              
338             L implements the following attributes.
339              
340             =head2 compressed
341              
342             my $bool = $t->compressed;
343             $t = $t->compressed($bool);
344              
345             Try to negotiate compression for the response content and decompress it automatically, defaults to the value of the
346             C environment variable or true.
347              
348             =head2 generators
349              
350             my $generators = $t->generators;
351             $t = $t->generators({foo => sub {...}});
352              
353             Registered content generators, by default only C
, C and C are already defined.
354              
355             =head2 name
356              
357             my $name = $t->name;
358             $t = $t->name('Mojolicious');
359              
360             Value for C request header of generated transactions, defaults to C.
361              
362             =head1 METHODS
363              
364             L inherits all methods from L and implements the following new ones.
365              
366             =head2 add_generator
367              
368             $t = $t->add_generator(foo => sub {...});
369              
370             Register a content generator.
371              
372             $t->add_generator(foo => sub ($t, $tx, @args) {...});
373              
374             =head2 endpoint
375              
376             my ($proto, $host, $port) = $t->endpoint(Mojo::Transaction::HTTP->new);
377              
378             Actual endpoint for transaction.
379              
380             =head2 peer
381              
382             my ($proto, $host, $port) = $t->peer(Mojo::Transaction::HTTP->new);
383              
384             Actual peer for transaction.
385              
386             =head2 promisify
387              
388             $t->promisify(Mojo::Promise->new, Mojo::Transaction::HTTP->new);
389              
390             Resolve or reject L object with L object.
391              
392             =head2 proxy_connect
393              
394             my $tx = $t->proxy_connect(Mojo::Transaction::HTTP->new);
395              
396             Build L proxy C request for transaction if possible.
397              
398             =head2 redirect
399              
400             my $tx = $t->redirect(Mojo::Transaction::HTTP->new);
401              
402             Build L follow-up request for C<301>, C<302>, C<303>, C<307> or C<308> redirect response if
403             possible.
404              
405             =head2 tx
406              
407             my $tx = $t->tx(GET => 'example.com');
408             my $tx = $t->tx(POST => 'http://example.com');
409             my $tx = $t->tx(GET => 'http://example.com' => {Accept => '*/*'});
410             my $tx = $t->tx(PUT => 'http://example.com' => 'Content!');
411             my $tx = $t->tx(PUT => 'http://example.com' => form => {a => 'b'});
412             my $tx = $t->tx(PUT => 'http://example.com' => json => {a => 'b'});
413             my $tx = $t->tx(PUT => 'https://example.com' => multipart => ['a', 'b']);
414             my $tx = $t->tx(POST => 'example.com' => {Accept => '*/*'} => 'Content!');
415             my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => form => {a => 'b'});
416             my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => json => {a => 'b'});
417             my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => multipart => ['a', 'b']);
418              
419             Versatile general purpose L transaction builder for requests, with support for
420             L.
421              
422             # Generate and inspect custom GET request with DNT header and content
423             say $t->tx(GET => 'example.com' => {DNT => 1} => 'Bye!')->req->to_string;
424              
425             # Stream response content to STDOUT
426             my $tx = $t->tx(GET => 'http://example.com');
427             $tx->res->content->unsubscribe('read')->on(read => sub { say $_[1] });
428              
429             # PUT request with content streamed from file
430             my $tx = $t->tx(PUT => 'http://example.com');
431             $tx->req->content->asset(Mojo::Asset::File->new(path => '/foo.txt'));
432              
433             The C content generator uses L for encoding and sets the content type to C.
434              
435             # POST request with "application/json" content
436             my $tx = $t->tx(POST => 'http://example.com' => json => {a => 'b', c => [1, 2, 3]});
437              
438             The C content generator will automatically use query parameters for C and C requests.
439              
440             # GET request with query parameters
441             my $tx = $t->tx(GET => 'http://example.com' => form => {a => 'b'});
442              
443             For all other request methods the C content type is used.
444              
445             # POST request with "application/x-www-form-urlencoded" content
446             my $tx = $t->tx(POST => 'http://example.com' => form => {a => 'b', c => 'd'});
447              
448             Parameters may be encoded with the C option.
449              
450             # PUT request with Shift_JIS encoded form values
451             my $tx = $t->tx(PUT => 'example.com' => form => {a => 'b'} => charset => 'Shift_JIS');
452              
453             An array reference can be used for multiple form values sharing the same name.
454              
455             # POST request with form values sharing the same name
456             my $tx = $t->tx(POST => 'http://example.com' => form => {a => ['b', 'c', 'd']});
457              
458             A hash reference with a C or C value can be used to switch to the C content type
459             for file uploads.
460              
461             # POST request with "multipart/form-data" content
462             my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {content => 'lala'}});
463              
464             # POST request with multiple files sharing the same name
465             my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => [{content => 'first'}, {content => 'second'}]});
466              
467             The C value should contain the path to the file you want to upload or an asset object, like L
468             or L.
469              
470             # POST request with upload streamed from file
471             my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {file => '/foo.txt'}});
472              
473             # POST request with upload streamed from asset
474             my $asset = Mojo::Asset::Memory->new->add_chunk('lalala');
475             my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {file => $asset}});
476              
477             A C value will be generated automatically, but can also be set manually if necessary. All remaining values in
478             the hash reference get merged into the C content as headers.
479              
480             # POST request with form values and customized upload (filename and header)
481             my $tx = $t->tx(POST => 'http://example.com' => form => {
482             a => 'b',
483             c => 'd',
484             mytext => {
485             content => 'lalala',
486             filename => 'foo.txt',
487             'Content-Type' => 'text/plain'
488             }
489             });
490              
491             The C content type can also be enforced by setting the C header manually.
492              
493             # Force "multipart/form-data"
494             my $headers = {'Content-Type' => 'multipart/form-data'};
495             my $tx = $t->tx(POST => 'example.com' => $headers => form => {a => 'b'});
496              
497             The C content generator can be used to build custom multipart requests and does not set a content type.
498              
499             # POST request with multipart content ("foo" and "bar")
500             my $tx = $t->tx(POST => 'http://example.com' => multipart => ['foo', 'bar']);
501              
502             Similar to the C content generator you can also pass hash references with C or C values, as well
503             as headers.
504              
505             # POST request with multipart content streamed from file
506             my $tx = $t->tx(POST => 'http://example.com' => multipart => [{file => '/foo.txt'}]);
507              
508             # PUT request with multipart content streamed from asset
509             my $headers = {'Content-Type' => 'multipart/custom'};
510             my $asset = Mojo::Asset::Memory->new->add_chunk('lalala');
511             my $tx = $t->tx(PUT => 'http://example.com' => $headers => multipart => [{file => $asset}]);
512              
513             # POST request with multipart content and custom headers
514             my $tx = $t->tx(POST => 'http://example.com' => multipart => [
515             {
516             content => 'Hello',
517             'Content-Type' => 'text/plain',
518             'Content-Language' => 'en-US'
519             },
520             {
521             content => 'World!',
522             'Content-Type' => 'text/plain',
523             'Content-Language' => 'en-US'
524             }
525             ]);
526              
527             =head2 upgrade
528              
529             my $tx = $t->upgrade(Mojo::Transaction::HTTP->new);
530              
531             Build L follow-up transaction for WebSocket handshake if possible.
532              
533             =head2 websocket
534              
535             my $tx = $t->websocket('ws://example.com');
536             my $tx = $t->websocket('ws://example.com' => {DNT => 1} => ['v1.proto']);
537              
538             Versatile L transaction builder for WebSocket handshake requests.
539              
540             =head1 SEE ALSO
541              
542             L, L, L.
543              
544             =cut