initial commit
[chaz/p5-HTTP-AnyUA] / lib / HTTP / AnyUA / Backend / Mojo / UserAgent.pm
1 package HTTP::AnyUA::Backend::Mojo::UserAgent;
2 # ABSTRACT: A unified programming interface for Mojo::UserAgent
3
4 =head1 DESCRIPTION
5
6 This module adds support for the HTTP client L<Mojo::UserAgent> to be used with the unified
7 programming interface provided by L<HTTP::AnyUA>.
8
9 =head1 CAVEATS
10
11 =for :list
12 * The C<url> field in the response has the auth portion (if any) removed from the URL.
13
14 =head1 SEE ALSO
15
16 =for :list
17 * L<HTTP::AnyUA::Backend>
18
19 =cut
20
21 use warnings;
22 use strict;
23
24 our $VERSION = '9999.999'; # VERSION
25
26 use parent 'HTTP::AnyUA::Backend';
27
28 use Future;
29 use Scalar::Util;
30
31
32 sub response_is_future { 1 }
33
34 sub request {
35 my $self = shift;
36 my ($method, $url, $args) = @_;
37
38 my $future = Future->new;
39
40 my $tx = $self->_munge_request(@_);
41
42 $self->ua->start($tx => sub {
43 my $ua = shift;
44 my $tx = shift;
45
46 my $resp = $self->_munge_response($tx, $args->{data_callback});
47
48 if ($resp->{success}) {
49 $future->done($resp);
50 }
51 else {
52 $future->fail($resp);
53 }
54 });
55
56 return $future;
57 }
58
59
60 sub _munge_request {
61 my $self = shift;
62 my $method = shift;
63 my $url = shift;
64 my $args = shift;
65
66 my $headers = $args->{headers} || {};
67 my $content = $args->{content};
68
69 my @content;
70
71 my $content_length;
72 if ($content) {
73 for my $header (keys %$headers) {
74 if (lc($header) eq 'content-length') {
75 $content_length = $headers->{$header};
76 last;
77 }
78 }
79
80 # if we don't know the length we have to just read it all in
81 $content = HTTP::AnyUA::Util::coderef_content_to_string($content) if !$content_length;
82
83 push @content, $content if ref($content) ne 'CODE';
84 }
85
86 my $tx = $self->ua->build_tx($method => $url => $headers => @content);
87
88 if (ref($content) eq 'CODE') {
89 $tx->req->headers->content_length($content_length);
90 # stream the request
91 my $drain;
92 $drain = sub {
93 my $body = shift;
94 my $chunk = $content->() || '';
95 undef $drain if !$chunk;
96 $body->write($chunk, $drain);
97 };
98 $tx->req->content->$drain;
99 }
100
101 if (my $data_cb = $args->{data_callback}) {
102 # stream the response
103 my $tx_copy = $tx;
104 Scalar::Util::weaken($tx_copy);
105 $tx->res->content->unsubscribe('read')->on(read => sub {
106 my ($content, $bytes) = @_;
107 my $resp = $self->_munge_response($tx_copy, undef);
108 $data_cb->($bytes, $resp);
109 });
110 }
111
112 return $tx;
113 }
114
115 sub _munge_response {
116 my $self = shift;
117 my $tx = shift;
118 my $data_cb = shift;
119 my $recurse = shift;
120
121 my $resp = {
122 success => !!$tx->res->is_success,
123 url => $tx->req->url->to_string,
124 status => $tx->res->code,
125 reason => $tx->res->message,
126 headers => {},
127 };
128
129 # lowercase header keys
130 my $headers = $tx->res->headers->to_hash;
131 for my $header (keys %$headers) {
132 $resp->{headers}{lc($header)} = delete $headers->{$header};
133 }
134
135 my $version = $tx->res->version;
136 $resp->{protocol} = "HTTP/$version" if $version;
137
138 if (!$recurse) {
139 for my $redirect (@{$tx->redirects}) {
140 push @{$resp->{redirects} ||= []}, $self->_munge_response($redirect, undef, 1);
141 }
142 }
143
144 my $err = $tx->error;
145 if ($err and !$err->{code}) {
146 return HTTP::AnyUA::Util::internal_exception($err->{message}, $resp);
147 }
148
149 my $body = $tx->res->body;
150 $resp->{content} = $body if $body && !$data_cb;
151
152 return $resp;
153 }
154
155 1;
This page took 0.039806 seconds and 4 git commands to generate.