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 =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 && !$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;