Dogcows Code - chaz/p5-HTTP-AnyUA/blob - lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm

   1 package HTTP::AnyUA::Backend::AnyEvent::HTTP;
   2 # ABSTRACT: A unified programming interface for AnyEvent::HTTP
   3
   4 =head1 DESCRIPTION
   5
   6 This module adds support for the HTTP client L<AnyEvent::HTTP> to be used with the unified
   7 programming interface provided by L<HTTP::AnyUA>.
   8
   9 =head1 SEE ALSO
  10
  11 =for :list
  12 * L<HTTP::AnyUA::Backend>
  13
  14 =cut
  15
  16 use warnings;
  17 use strict;
  18
  19 our $VERSION = '9999.999'; # VERSION
  20
  21 use parent 'HTTP::AnyUA::Backend';
  22
  23 use Future;
  24 use HTTP::AnyUA::Util;
  25
  26
  27 =method options
  28
  29     $backend->options(\%options);
  30
  31 Get and set default arguments to C<http_request>.
  32
  33 =cut
  34
  35 sub options { @_ == 2 ? $_[0]->{options} = pop : $_[0]->{options} }
  36
  37 sub response_is_future { 1 }
  38
  39 sub request {
  40     my $self = shift;
  41     my ($method, $url, $args) = @_;
  42
  43     my %opts    = $self->_munge_request($method, $url, $args);
  44     my $future  = Future->new;
  45
  46     require AnyEvent::HTTP;
  47     AnyEvent::HTTP::http_request($method => $url, %opts, sub {
  48         my $resp = $self->_munge_response(@_, $args->{data_callback});
  49
  50         if ($resp->{success}) {
  51             $future->done($resp);
  52         }
  53         else {
  54             $future->fail($resp);
  55         }
  56     });
  57
  58     return $future;
  59 }
  60
  61
  62 sub _munge_request {
  63     my $self    = shift;
  64     my $method  = shift;
  65     my $url     = shift;
  66     my $args    = shift || {};
  67
  68     my %opts = %{$self->options || {}};
  69
  70     if (my $headers = $args->{headers}) {
  71         # munge headers
  72         my %headers;
  73         for my $header (keys %$headers) {
  74             my $value  = $headers->{$header};
  75             $value = join(', ', @$value) if ref($value) eq 'ARRAY';
  76             $headers{$header} = $value;
  77         }
  78         $opts{headers} = \%headers;
  79     }
  80
  81     my @url_parts = HTTP::AnyUA::Util::split_url($url);
  82     if (my $auth = $url_parts[4] and !$opts{headers}{'authorization'}) {
  83         # handle auth in the URL
  84         require MIME::Base64;
  85         $opts{headers}{'authorization'} = 'Basic ' . MIME::Base64::encode_base64($auth, '');
  86     }
  87
  88     my $content = HTTP::AnyUA::Util::coderef_content_to_string($args->{content});
  89     $opts{body} = $content if $content;
  90
  91     if (my $data_cb = $args->{data_callback}) {
  92         # stream the response
  93         $opts{on_body} = sub {
  94             my $data = shift;
  95             $data_cb->($data, $self->_munge_response(undef, @_));
  96             1;  # continue
  97         };
  98     }
  99
 100     return %opts;
 101 }
 102
 103 sub _munge_response {
 104     my $self    = shift;
 105     my $data    = shift;
 106     my $headers = shift;
 107     my $data_cb = shift;
 108
 109     # copy headers because http_request will continue to use the original
 110     my %headers = %$headers;
 111
 112     my $code    = delete $headers{Status};
 113     my $reason  = delete $headers{Reason};
 114     my $url     = delete $headers{URL};
 115
 116     my $resp = {
 117         success => 200 <= $code && $code <= 299,
 118         url     => $url,
 119         status  => $code,
 120         reason  => $reason,
 121         headers => \%headers,
 122     };
 123
 124     my $version = delete $headers{HTTPVersion};
 125     $resp->{protocol} = "HTTP/$version" if $version;
 126
 127     $resp->{content} = $data if $data && !$data_cb;
 128
 129     my @redirects;
 130     my $redirect = delete $headers{Redirect};
 131     while ($redirect) {
 132         # delete pseudo-header first so redirects aren't recursively munged
 133         my $next = delete $redirect->[1]{Redirect};
 134         unshift @redirects, $self->_munge_response(@$redirect);
 135         $redirect = $next;
 136     }
 137     $resp->{redirects} = \@redirects if @redirects;
 138
 139     if (590 <= $code && $code <= 599) {
 140         HTTP::AnyUA::Util::internal_exception($reason, $resp);
 141     }
 142
 143     return $resp;
 144 }
 145
 146 1;