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