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

   1 package HTTP::AnyUA::Util;
   2 # ABSTRACT: Utility subroutines for HTTP::AnyUA backends and middleware
   3
   4 use warnings;
   5 use strict;
   6
   7 our $VERSION = '9999.999'; # VERSION
   8
   9 use Exporter qw(import);
  10
  11
  12 our @EXPORT_OK = qw(
  13     http_headers_to_native
  14     native_to_http_request
  15     coderef_content_to_string
  16     normalize_headers
  17     internal_exception
  18     http_date
  19     parse_http_date
  20     uri_escape
  21     www_form_urlencode
  22 );
  23
  24
  25 sub _croak { require Carp; Carp::croak(@_) }
  26 sub _usage { _croak("Usage: @_\n") }
  27
  28 =func coderef_content_to_string
  29
  30     $content = coderef_content_to_string(\&code);
  31     $content = coderef_content_to_string($content);     # noop
  32
  33 Convert a coderef into a string of content by iteratively calling the coderef and concatenating the
  34 chunks it provides until the coderef returns undef or an empty string.
  35
  36 =cut
  37
  38 sub coderef_content_to_string {
  39     my $content = shift;
  40
  41     return $content if !$content;
  42
  43     if (ref($content) eq 'CODE') {
  44         # drain the request body
  45         my $body = '';
  46         while (my $chunk = $content->()) {
  47             $body .= $chunk;
  48         }
  49         $content = $body;
  50     }
  51
  52     return $content;
  53 }
  54
  55 =func native_to_http_request
  56
  57     $http_request = native_to_http_request($method, $url);
  58     $http_request = native_to_http_request($method, $url, \%options);
  59
  60 Convert a "native" request tuple to an L<HTTP::Request> object.
  61
  62 =cut
  63
  64 sub native_to_http_request {
  65     my $method  = shift;
  66     my $url     = shift;
  67     my $args    = shift || {};
  68
  69     my $headers = [];
  70     my $content = $args->{content};     # works as either scalar or coderef
  71
  72     # flatten headers
  73     for my $header (keys %{$args->{headers} || {}}) {
  74         my $value  = $args->{headers}{$header};
  75         my @values = ref($value) eq 'ARRAY' ? @$value : ($value);
  76         for my $v (@values) {
  77             push @$headers, ($header => $v);
  78         }
  79     }
  80
  81     require HTTP::Request;
  82     return HTTP::Request->new($method, $url, $headers, $content);
  83 }
  84
  85 =func http_headers_to_native
  86
  87     $headers = http_headers_to_native($http_headers);
  88
  89 Convert an L<HTTP::Headers> object to a "native" hashref.
  90
  91 =cut
  92
  93 sub http_headers_to_native {
  94     my $http_headers = shift;
  95
  96     my $native;
  97
  98     for my $header ($http_headers->header_field_names) {
  99         my @values = $http_headers->header($header);
 100         $native->{lc($header)} = @values == 1 ? $values[0] : [@values];
 101     }
 102
 103     return $native;
 104 }
 105
 106 =func normalize_headers
 107
 108     $normalized_headers = normalize_headers(\%headers);
 109
 110 Normalize headers. Currently lowercases header keys.
 111
 112 =cut
 113
 114 sub normalize_headers {
 115     my $headers_in = shift;
 116
 117     my $headers = {};
 118
 119     if (defined $headers_in) {
 120         while (my ($key, $value) = each %{$headers_in || {}}) {
 121             $headers->{lc($key)} = $value;
 122         }
 123     }
 124
 125     return $headers;
 126 }
 127
 128 =func internal_exception
 129
 130     $response = internal_exception($content);
 131     $response = internal_exception($content, $response);
 132
 133 Create an internal exception response. If an existing response is passed, that response will have
 134 its fields modified to become an internal exception.
 135
 136 =cut
 137
 138 sub internal_exception {
 139     my $e       = shift or _usage(q{internal_exception($exception)});
 140     my $resp    = shift || {};
 141
 142     $e = "$e";
 143
 144     $resp->{headers}{'client-original-status'} = $resp->{status} if $resp->{status};
 145     $resp->{headers}{'client-original-reason'} = $resp->{reason} if $resp->{reason};
 146
 147     $resp->{success}    = '';
 148     $resp->{status}     = 599;
 149     $resp->{reason}     = 'Internal Exception';
 150     $resp->{content}    = $e;
 151     $resp->{headers}{'content-type'}    = 'text/plain';
 152     $resp->{headers}{'content-length'}  = length $e;
 153
 154     return $resp;
 155 }
 156
 157 =func split_url
 158
 159     ($scheme, $host, $port, $path_query, $auth) = split_url($url);
 160
 161 Split a URL into its components.
 162
 163 =cut
 164
 165 # adapted from HTTP/Tiny.pm
 166 sub split_url {
 167     my $url = shift or _usage(q{split_url($url)});
 168
 169     # URI regex adapted from the URI module
 170     my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
 171         or die(qq/Cannot parse URL: '$url'\n/);
 172
 173     $scheme     = lc $scheme;
 174     $path_query = "/$path_query" unless $path_query =~ m<\A/>;
 175
 176     my $auth = '';
 177     if ( (my $i = index $host, '@') != -1 ) {
 178         # user:pass@host
 179         $auth = substr $host, 0, $i, ''; # take up to the @ for auth
 180         substr $host, 0, 1, '';          # knock the @ off the host
 181
 182         # userinfo might be percent escaped, so recover real auth info
 183         $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 184     }
 185     my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
 186              : $scheme eq 'http'                  ? 80
 187              : $scheme eq 'https'                 ? 443
 188              : undef;
 189
 190     return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
 191 }
 192
 193 =func http_date
 194
 195     $http_date = http_date($epoch_time);
 196
 197 Convert an epoch time into a date format suitable for HTTP.
 198
 199 =cut
 200
 201 # Date conversions adapted from HTTP::Date
 202 # adapted from HTTP/Tiny.pm
 203 my $DoW = 'Sun|Mon|Tue|Wed|Thu|Fri|Sat';
 204 my $MoY = 'Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec';
 205 sub http_date {
 206     my $time = shift or _usage(q{http_date($time)});
 207     my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
 208     return sprintf('%s, %02d %s %04d %02d:%02d:%02d GMT',
 209         substr($DoW,$wday*4,3),
 210         $mday, substr($MoY,$mon*4,3), $year+1900,
 211         $hour, $min, $sec
 212     );
 213 }
 214
 215 =func parse_http_date
 216
 217     $epoch_time = parse_http_date($http_date);
 218
 219 Convert an HTTP date into an epoch time. Returns undef if the date cannot be parsed.
 220
 221 =cut
 222
 223 # adapted from HTTP/Tiny.pm
 224 sub parse_http_date {
 225     my $str = shift or _usage(q{parse_http_date($str)});
 226     my @tl_parts;
 227     if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
 228         @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
 229     }
 230     elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
 231         @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
 232     }
 233     elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
 234         @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
 235     }
 236     require Time::Local;
 237     return eval {
 238         my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
 239         $t < 0 ? undef : $t;
 240     };
 241 }
 242
 243 =func uri_escape
 244
 245     $escaped = uri_escape($unescaped);
 246
 247 Escape a string for use in a URL query param or as C<application/x-www-form-urlencoded> data.
 248
 249 =cut
 250
 251 # URI escaping adapted from URI::Escape
 252 # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
 253 # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
 254 # adapted from HTTP/Tiny.pm
 255 my %escapes = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
 256 $escapes{' '} = '+';
 257 my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
 258
 259 sub uri_escape {
 260     my $str = shift or _usage(q{uri_escape($str)});
 261     if ($] ge '5.008') {
 262         utf8::encode($str);
 263     }
 264     else {
 265         $str = pack('U*', unpack('C*', $str))   # UTF-8 encode a byte string
 266             if (length $str == do { use bytes; length $str });
 267         $str = pack('C*', unpack('C*', $str));  # clear UTF-8 flag
 268     }
 269     $str =~ s/($unsafe_char)/$escapes{$1}/ge;
 270     return $str;
 271 }
 272
 273 =func www_form_urlencode
 274
 275     $bytes = www_form_urlencode(\%form_data);
 276     $bytes = www_form_urlencode(\@form_data);
 277
 278 Encode a hashref or arrayref as C<application/x-www-form-urlencoded> data.
 279
 280 =cut
 281
 282 # adapted from HTTP/Tiny.pm
 283 sub www_form_urlencode {
 284     my $data = shift;
 285     ($data && ref $data)
 286         or _usage(q{www_form_urlencode($dataref)});
 287     (ref $data eq 'HASH' || ref $data eq 'ARRAY')
 288         or _croak("form data must be a hash or array reference\n");
 289
 290     my @params = ref $data eq 'HASH' ? %$data : @$data;
 291     @params % 2 == 0
 292         or _croak("form data reference must have an even number of terms\n");
 293
 294     my @terms;
 295     while (@params) {
 296         my ($key, $value) = splice(@params, 0, 2);
 297         if (ref $value eq 'ARRAY') {
 298             unshift @params, map { $key => $_ } @$value;
 299         }
 300         else {
 301             push @terms, join('=', map { uri_escape($_) } $key, $value);
 302         }
 303     }
 304
 305     return join('&', ref($data) eq 'ARRAY' ? @terms : sort @terms);
 306 }
 307
 308 1;