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