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
   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 HTTP::AnyUA::Util;
  14
  15
  16
  17 sub options { @_ == 2 ? $_[0]->{options} = pop : $_[0]->{options} }
  18
  19 sub response_is_future { 1 }
  20
  21 sub request {
  22     my $self = shift;
  23     my ($method, $url, $args) = @_;
  24
  25     my %opts    = $self->_munge_request($method, $url, $args);
  26     my $future  = Future->new;
  27
  28     require AnyEvent::HTTP;
  29     AnyEvent::HTTP::http_request($method => $url, %opts, sub {
  30         my $resp = $self->_munge_response(@_, $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 %opts = %{$self->options || {}};
  51
  52     if (my $headers = $args->{headers}) {
  53         # munge headers
  54         my %headers;
  55         for my $header (keys %$headers) {
  56             my $value  = $headers->{$header};
  57             $value = join(', ', @$value) if ref($value) eq 'ARRAY';
  58             $headers{$header} = $value;
  59         }
  60         $opts{headers} = \%headers;
  61     }
  62
  63     my @url_parts = HTTP::AnyUA::Util::split_url($url);
  64     if (my $auth = $url_parts[4] and !$opts{headers}{'authorization'}) {
  65         # handle auth in the URL
  66         require MIME::Base64;
  67         $opts{headers}{'authorization'} = 'Basic ' . MIME::Base64::encode_base64($auth, '');
  68     }
  69
  70     my $content = HTTP::AnyUA::Util::coderef_content_to_string($args->{content});
  71     $opts{body} = $content if $content;
  72
  73     if (my $data_cb = $args->{data_callback}) {
  74         # stream the response
  75         $opts{on_body} = sub {
  76             my $data = shift;
  77             $data_cb->($data, $self->_munge_response(undef, @_));
  78             1;  # continue
  79         };
  80     }
  81
  82     return %opts;
  83 }
  84
  85 sub _munge_response {
  86     my $self    = shift;
  87     my $data    = shift;
  88     my $headers = shift;
  89     my $data_cb = shift;
  90
  91     # copy headers because http_request will continue to use the original
  92     my %headers = %$headers;
  93
  94     my $code    = delete $headers{Status};
  95     my $reason  = delete $headers{Reason};
  96     my $url     = delete $headers{URL};
  97
  98     my $resp = {
  99         success => 200 <= $code && $code <= 299,
 100         url     => $url,
 101         status  => $code,
 102         reason  => $reason,
 103         headers => \%headers,
 104     };
 105
 106     my $version = delete $headers{HTTPVersion};
 107     $resp->{protocol} = "HTTP/$version" if $version;
 108
 109     $resp->{content} = $data if $data && !$data_cb;
 110
 111     my @redirects;
 112     my $redirect = delete $headers{Redirect};
 113     while ($redirect) {
 114         # delete pseudo-header first so redirects aren't recursively munged
 115         my $next = delete $redirect->[1]{Redirect};
 116         unshift @redirects, $self->_munge_response(@$redirect);
 117         $redirect = $next;
 118     }
 119     $resp->{redirects} = \@redirects if @redirects;
 120
 121     if (590 <= $code && $code <= 599) {
 122         HTTP::AnyUA::Util::internal_exception($reason, $resp);
 123     }
 124
 125     return $resp;
 126 }
 127
 128 1;
 129
 130 __END__
 131
 132 =pod
 133
 134 =encoding UTF-8
 135
 136 =head1 NAME
 137
 138 HTTP::AnyUA::Backend::AnyEvent::HTTP - A unified programming interface for AnyEvent::HTTP
 139
 140 =head1 VERSION
 141
 142 version 0.900
 143
 144 =head1 DESCRIPTION
 145
 146 This module adds support for the HTTP client L<AnyEvent::HTTP> to be used with the unified
 147 programming interface provided by L<HTTP::AnyUA>.
 148
 149 =head1 METHODS
 150
 151 =head2 options
 152
 153     $backend->options(\%options);
 154
 155 Get and set default arguments to C<http_request>.
 156
 157 =head1 SEE ALSO
 158
 159 =over 4
 160
 161 =item *
 162
 163 L<HTTP::AnyUA::Backend>
 164
 165 =back
 166
 167 =head1 BUGS
 168
 169 Please report any bugs or feature requests on the bugtracker website
 170 L<https://github.com/chazmcgarvey/HTTP-AnyUA/issues>
 171
 172 When submitting a bug or request, please include a test-file or a
 173 patch to an existing test-file that illustrates the bug or desired
 174 feature.
 175
 176 =head1 AUTHOR
 177
 178 Charles McGarvey <chazmcgarvey@brokenzipper.com>
 179
 180 =head1 COPYRIGHT AND LICENSE
 181
 182 This software is copyright (c) 2017 by Charles McGarvey.
 183
 184 This is free software; you can redistribute it and/or modify it under
 185 the same terms as the Perl 5 programming language system itself.
 186
 187 =cut