Dogcows Code - chaz/p5-HTTP-AnyUA/blob - 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
   5 use warnings;
   6 use strict;
   7
   8 our $VERSION = '0.900'; # VERSION
   9
  10 use parent 'HTTP::AnyUA::Backend';
  11
  12 use Future;
  13 use Scalar::Util;
  14
  15
  16 sub response_is_future { 1 }
  17
  18 sub request {
  19     my $self = shift;
  20     my ($method, $url, $args) = @_;
  21
  22     my $future = Future->new;
  23
  24     my $tx = $self->_munge_request(@_);
  25
  26     $self->ua->start($tx => sub {
  27         my $ua = shift;
  28         my $tx = shift;
  29
  30         my $resp = $self->_munge_response($tx, $args->{data_callback});
  31
  32         if ($resp->{success}) {
  33             $future->done($resp);
  34         }
  35         else {
  36             $future->fail($resp);
  37         }
  38     });
  39
  40     return $future;
  41 }
  42
  43
  44 sub _munge_request {
  45     my $self    = shift;
  46     my $method  = shift;
  47     my $url     = shift;
  48     my $args    = shift;
  49
  50     my $headers = $args->{headers} || {};
  51     my $content = $args->{content};
  52
  53     my @content;
  54
  55     my $content_length;
  56     if ($content) {
  57         for my $header (keys %$headers) {
  58             if (lc($header) eq 'content-length') {
  59                 $content_length = $headers->{$header};
  60                 last;
  61             }
  62         }
  63
  64         # if we don't know the length we have to just read it all in
  65         $content = HTTP::AnyUA::Util::coderef_content_to_string($content) if !$content_length;
  66
  67         push @content, $content if ref($content) ne 'CODE';
  68     }
  69
  70     my $tx = $self->ua->build_tx($method => $url => $headers => @content);
  71
  72     if (ref($content) eq 'CODE') {
  73         $tx->req->headers->content_length($content_length);
  74         # stream the request
  75         my $drain;
  76         $drain = sub {
  77             my $body    = shift;
  78             my $chunk   = $content->() || '';
  79             undef $drain if !$chunk;
  80             $body->write($chunk, $drain);
  81         };
  82         $tx->req->content->$drain;
  83     }
  84
  85     if (my $data_cb = $args->{data_callback}) {
  86         # stream the response
  87         my $tx_copy = $tx;
  88         Scalar::Util::weaken($tx_copy);
  89         $tx->res->content->unsubscribe('read')->on(read => sub {
  90             my ($content, $bytes) = @_;
  91             my $resp = $self->_munge_response($tx_copy, undef);
  92             $data_cb->($bytes, $resp);
  93         });
  94     }
  95
  96     return $tx;
  97 }
  98
  99 sub _munge_response {
 100     my $self    = shift;
 101     my $tx      = shift;
 102     my $data_cb = shift;
 103     my $recurse = shift;
 104
 105     my $resp = {
 106         success => !!$tx->res->is_success,
 107         url     => $tx->req->url->to_string,
 108         status  => $tx->res->code,
 109         reason  => $tx->res->message,
 110         headers => {},
 111     };
 112
 113     # lowercase header keys
 114     my $headers = $tx->res->headers->to_hash;
 115     for my $header (keys %$headers) {
 116         $resp->{headers}{lc($header)} = delete $headers->{$header};
 117     }
 118
 119     my $version = $tx->res->version;
 120     $resp->{protocol} = "HTTP/$version" if $version;
 121
 122     if (!$recurse) {
 123         for my $redirect (@{$tx->redirects}) {
 124             push @{$resp->{redirects} ||= []}, $self->_munge_response($redirect, undef, 1);
 125         }
 126     }
 127
 128     my $err = $tx->error;
 129     if ($err and !$err->{code}) {
 130         return HTTP::AnyUA::Util::internal_exception($err->{message}, $resp);
 131     }
 132
 133     my $body = $tx->res->body;
 134     $resp->{content} = $body if $body && !$data_cb;
 135
 136     return $resp;
 137 }
 138
 139 1;
 140
 141 __END__
 142
 143 =pod
 144
 145 =encoding UTF-8
 146
 147 =head1 NAME
 148
 149 HTTP::AnyUA::Backend::Mojo::UserAgent - A unified programming interface for Mojo::UserAgent
 150
 151 =head1 VERSION
 152
 153 version 0.900
 154
 155 =head1 DESCRIPTION
 156
 157 This module adds support for the HTTP client L<Mojo::UserAgent> to be used with the unified
 158 programming interface provided by L<HTTP::AnyUA>.
 159
 160 =head1 CAVEATS
 161
 162 =over 4
 163
 164 =item *
 165
 166 The C<url> field in the response has the auth portion (if any) removed from the URL.
 167
 168 =back
 169
 170 =head1 SEE ALSO
 171
 172 =over 4
 173
 174 =item *
 175
 176 L<HTTP::AnyUA::Backend>
 177
 178 =back
 179
 180 =head1 BUGS
 181
 182 Please report any bugs or feature requests on the bugtracker website
 183 L<https://github.com/chazmcgarvey/HTTP-AnyUA/issues>
 184
 185 When submitting a bug or request, please include a test-file or a
 186 patch to an existing test-file that illustrates the bug or desired
 187 feature.
 188
 189 =head1 AUTHOR
 190
 191 Charles McGarvey <chazmcgarvey@brokenzipper.com>
 192
 193 =head1 COPYRIGHT AND LICENSE
 194
 195 This software is copyright (c) 2017 by Charles McGarvey.
 196
 197 This is free software; you can redistribute it and/or modify it under
 198 the same terms as the Perl 5 programming language system itself.
 199
 200 =cut