cpan/HTTP-Tiny/lib/HTTP/Tiny.pm

   1 # vim: ts=4 sts=4 sw=4 et:
   2 package HTTP::Tiny;
   3 use strict;
   4 use warnings;
   5 # ABSTRACT: A small, simple, correct HTTP/1.1 client
   6 our $VERSION = '0.022'; # VERSION
   7
   8 use Carp ();
   9
  10
  11 my @attributes;
  12 BEGIN {
  13     @attributes = qw(agent default_headers local_address max_redirect max_size proxy timeout SSL_options verify_SSL);
  14     no strict 'refs';
  15     for my $accessor ( @attributes ) {
  16         *{$accessor} = sub {
  17             @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
  18         };
  19     }
  20 }
  21
  22 sub new {
  23     my($class, %args) = @_;
  24     (my $agent = $class) =~ s{::}{-}g;
  25     my $self = {
  26         agent        => $agent . "/" . ($class->VERSION || 0),
  27         max_redirect => 5,
  28         timeout      => 60,
  29         verify_SSL   => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
  30     };
  31     for my $key ( @attributes ) {
  32         $self->{$key} = $args{$key} if exists $args{$key}
  33     }
  34
  35     # Never override proxy argument as this breaks backwards compat.
  36     if (!exists $self->{proxy} && (my $http_proxy = $ENV{http_proxy})) {
  37         if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}) {
  38             $self->{proxy} = $http_proxy;
  39         }
  40         else {
  41             Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n});
  42         }
  43     }
  44
  45     return bless $self, $class;
  46 }
  47
  48
  49 for my $sub_name ( qw/get head put post delete/ ) {
  50     my $req_method = uc $sub_name;
  51     no strict 'refs';
  52     eval <<"HERE"; ## no critic
  53     sub $sub_name {
  54         my (\$self, \$url, \$args) = \@_;
  55         \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
  56         or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
  57         return \$self->request('$req_method', \$url, \$args || {});
  58     }
  59 HERE
  60 }
  61
  62
  63 sub post_form {
  64     my ($self, $url, $data, $args) = @_;
  65     (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
  66         or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
  67
  68     my $headers = {};
  69     while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
  70         $headers->{lc $key} = $value;
  71     }
  72     delete $args->{headers};
  73
  74     return $self->request('POST', $url, {
  75             %$args,
  76             content => $self->www_form_urlencode($data),
  77             headers => {
  78                 %$headers,
  79                 'content-type' => 'application/x-www-form-urlencoded'
  80             },
  81         }
  82     );
  83 }
  84
  85
  86 sub mirror {
  87     my ($self, $url, $file, $args) = @_;
  88     @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
  89       or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
  90     if ( -e $file and my $mtime = (stat($file))[9] ) {
  91         $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
  92     }
  93     my $tempfile = $file . int(rand(2**31));
  94     open my $fh, ">", $tempfile
  95         or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);
  96     binmode $fh;
  97     $args->{data_callback} = sub { print {$fh} $_[0] };
  98     my $response = $self->request('GET', $url, $args);
  99     close $fh
 100         or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/);
 101     if ( $response->{success} ) {
 102         rename $tempfile, $file
 103             or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
 104         my $lm = $response->{headers}{'last-modified'};
 105         if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
 106             utime $mtime, $mtime, $file;
 107         }
 108     }
 109     $response->{success} ||= $response->{status} eq '304';
 110     unlink $tempfile;
 111     return $response;
 112 }
 113
 114
 115 my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
 116
 117 sub request {
 118     my ($self, $method, $url, $args) = @_;
 119     @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
 120       or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
 121     $args ||= {}; # we keep some state in this during _request
 122
 123     # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
 124     my $response;
 125     for ( 0 .. 1 ) {
 126         $response = eval { $self->_request($method, $url, $args) };
 127         last unless $@ && $idempotent{$method}
 128             && $@ =~ m{^(?:Socket closed|Unexpected end)};
 129     }
 130
 131     if (my $e = "$@") {
 132         $response = {
 133             url     => $url,
 134             success => q{},
 135             status  => 599,
 136             reason  => 'Internal Exception',
 137             content => $e,
 138             headers => {
 139                 'content-type'   => 'text/plain',
 140                 'content-length' => length $e,
 141             }
 142         };
 143     }
 144     return $response;
 145 }
 146
 147
 148 sub www_form_urlencode {
 149     my ($self, $data) = @_;
 150     (@_ == 2 && ref $data)
 151         or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
 152     (ref $data eq 'HASH' || ref $data eq 'ARRAY')
 153         or Carp::croak("form data must be a hash or array reference");
 154
 155     my @params = ref $data eq 'HASH' ? %$data : @$data;
 156     @params % 2 == 0
 157         or Carp::croak("form data reference must have an even number of terms\n");
 158
 159     my @terms;
 160     while( @params ) {
 161         my ($key, $value) = splice(@params, 0, 2);
 162         if ( ref $value eq 'ARRAY' ) {
 163             unshift @params, map { $key => $_ } @$value;
 164         }
 165         else {
 166             push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
 167         }
 168     }
 169
 170     return join("&", sort @terms);
 171 }
 172
 173 #--------------------------------------------------------------------------#
 174 # private methods
 175 #--------------------------------------------------------------------------#
 176
 177 my %DefaultPort = (
 178     http => 80,
 179     https => 443,
 180 );
 181
 182 sub _request {
 183     my ($self, $method, $url, $args) = @_;
 184
 185     my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
 186
 187     my $request = {
 188         method    => $method,
 189         scheme    => $scheme,
 190         host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
 191         uri       => $path_query,
 192         headers   => {},
 193     };
 194
 195     my $handle  = HTTP::Tiny::Handle->new(
 196         timeout         => $self->{timeout},
 197         SSL_options     => $self->{SSL_options},
 198         verify_SSL      => $self->{verify_SSL},
 199         local_address   => $self->{local_address},
 200     );
 201
 202     if ($self->{proxy}) {
 203         $request->{uri} = "$scheme://$request->{host_port}$path_query";
 204         die(qq/HTTPS via proxy is not supported\n/)
 205             if $request->{scheme} eq 'https';
 206         $handle->connect(($self->_split_url($self->{proxy}))[0..2]);
 207     }
 208     else {
 209         $handle->connect($scheme, $host, $port);
 210     }
 211
 212     $self->_prepare_headers_and_cb($request, $args);
 213     $handle->write_request($request);
 214
 215     my $response;
 216     do { $response = $handle->read_response_header }
 217         until (substr($response->{status},0,1) ne '1');
 218
 219     if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
 220         $handle->close;
 221         return $self->_request(@redir_args, $args);
 222     }
 223
 224     if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
 225         # response has no message body
 226     }
 227     else {
 228         my $data_cb = $self->_prepare_data_cb($response, $args);
 229         $handle->read_body($data_cb, $response);
 230     }
 231
 232     $handle->close;
 233     $response->{success} = substr($response->{status},0,1) eq '2';
 234     $response->{url} = $url;
 235     return $response;
 236 }
 237
 238 sub _prepare_headers_and_cb {
 239     my ($self, $request, $args) = @_;
 240
 241     for ($self->{default_headers}, $args->{headers}) {
 242         next unless defined;
 243         while (my ($k, $v) = each %$_) {
 244             $request->{headers}{lc $k} = $v;
 245         }
 246     }
 247     $request->{headers}{'host'}         = $request->{host_port};
 248     $request->{headers}{'connection'}   = "close";
 249     $request->{headers}{'user-agent'} ||= $self->{agent};
 250
 251     if (defined $args->{content}) {
 252         $request->{headers}{'content-type'} ||= "application/octet-stream";
 253         if (ref $args->{content} eq 'CODE') {
 254             $request->{headers}{'transfer-encoding'} = 'chunked'
 255               unless $request->{headers}{'content-length'}
 256                   || $request->{headers}{'transfer-encoding'};
 257             $request->{cb} = $args->{content};
 258         }
 259         else {
 260             my $content = $args->{content};
 261             if ( $] ge '5.008' ) {
 262                 utf8::downgrade($content, 1)
 263                     or die(qq/Wide character in request message body\n/);
 264             }
 265             $request->{headers}{'content-length'} = length $content
 266               unless $request->{headers}{'content-length'}
 267                   || $request->{headers}{'transfer-encoding'};
 268             $request->{cb} = sub { substr $content, 0, length $content, '' };
 269         }
 270         $request->{trailer_cb} = $args->{trailer_callback}
 271             if ref $args->{trailer_callback} eq 'CODE';
 272     }
 273     return;
 274 }
 275
 276 sub _prepare_data_cb {
 277     my ($self, $response, $args) = @_;
 278     my $data_cb = $args->{data_callback};
 279     $response->{content} = '';
 280
 281     if (!$data_cb || $response->{status} !~ /^2/) {
 282         if (defined $self->{max_size}) {
 283             $data_cb = sub {
 284                 $_[1]->{content} .= $_[0];
 285                 die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
 286                   if length $_[1]->{content} > $self->{max_size};
 287             };
 288         }
 289         else {
 290             $data_cb = sub { $_[1]->{content} .= $_[0] };
 291         }
 292     }
 293     return $data_cb;
 294 }
 295
 296 sub _maybe_redirect {
 297     my ($self, $request, $response, $args) = @_;
 298     my $headers = $response->{headers};
 299     my ($status, $method) = ($response->{status}, $request->{method});
 300     if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
 301         and $headers->{location}
 302         and ++$args->{redirects} <= $self->{max_redirect}
 303     ) {
 304         my $location = ($headers->{location} =~ /^\//)
 305             ? "$request->{scheme}://$request->{host_port}$headers->{location}"
 306             : $headers->{location} ;
 307         return (($status eq '303' ? 'GET' : $method), $location);
 308     }
 309     return;
 310 }
 311
 312 sub _split_url {
 313     my $url = pop;
 314
 315     # URI regex adapted from the URI module
 316     my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
 317       or die(qq/Cannot parse URL: '$url'\n/);
 318
 319     $scheme     = lc $scheme;
 320     $path_query = "/$path_query" unless $path_query =~ m<\A/>;
 321
 322     my $host = (length($authority)) ? lc $authority : 'localhost';
 323        $host =~ s/\A[^@]*@//;   # userinfo
 324     my $port = do {
 325        $host =~ s/:([0-9]*)\z// && length $1
 326          ? $1
 327          : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
 328     };
 329
 330     return ($scheme, $host, $port, $path_query);
 331 }
 332
 333 # Date conversions adapted from HTTP::Date
 334 my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
 335 my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
 336 sub _http_date {
 337     my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
 338     return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
 339         substr($DoW,$wday*4,3),
 340         $mday, substr($MoY,$mon*4,3), $year+1900,
 341         $hour, $min, $sec
 342     );
 343 }
 344
 345 sub _parse_http_date {
 346     my ($self, $str) = @_;
 347     require Time::Local;
 348     my @tl_parts;
 349     if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
 350         @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
 351     }
 352     elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
 353         @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
 354     }
 355     elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
 356         @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
 357     }
 358     return eval {
 359         my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
 360         $t < 0 ? undef : $t;
 361     };
 362 }
 363
 364 # URI escaping adapted from URI::Escape
 365 # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
 366 # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
 367 my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
 368 $escapes{' '}="+";
 369 my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
 370
 371 sub _uri_escape {
 372     my ($self, $str) = @_;
 373     if ( $] ge '5.008' ) {
 374         utf8::encode($str);
 375     }
 376     else {
 377         $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
 378             if ( length $str == do { use bytes; length $str } );
 379         $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
 380     }
 381     $str =~ s/($unsafe_char)/$escapes{$1}/ge;
 382     return $str;
 383 }
 384
 385 package
 386     HTTP::Tiny::Handle; # hide from PAUSE/indexers
 387 use strict;
 388 use warnings;
 389
 390 use Errno      qw[EINTR EPIPE];
 391 use IO::Socket qw[SOCK_STREAM];
 392
 393 sub BUFSIZE () { 32768 } ## no critic
 394
 395 my $Printable = sub {
 396     local $_ = shift;
 397     s/\r/\\r/g;
 398     s/\n/\\n/g;
 399     s/\t/\\t/g;
 400     s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
 401     $_;
 402 };
 403
 404 my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
 405
 406 sub new {
 407     my ($class, %args) = @_;
 408     return bless {
 409         rbuf             => '',
 410         timeout          => 60,
 411         max_line_size    => 16384,
 412         max_header_lines => 64,
 413         verify_SSL       => 0,
 414         SSL_options      => {},
 415         %args
 416     }, $class;
 417 }
 418
 419 sub connect {
 420     @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
 421     my ($self, $scheme, $host, $port) = @_;
 422
 423     if ( $scheme eq 'https' ) {
 424         die(qq/IO::Socket::SSL 1.56 must be installed for https support\n/)
 425             unless eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.56)};
 426     }
 427     elsif ( $scheme ne 'http' ) {
 428       die(qq/Unsupported URL scheme '$scheme'\n/);
 429     }
 430     $self->{fh} = 'IO::Socket::INET'->new(
 431         PeerHost  => $host,
 432         PeerPort  => $port,
 433         $self->{local_address} ?
 434             ( LocalAddr => $self->{local_address} ) : (),
 435         Proto     => 'tcp',
 436         Type      => SOCK_STREAM,
 437         Timeout   => $self->{timeout}
 438     ) or die(qq/Could not connect to '$host:$port': $@\n/);
 439
 440     binmode($self->{fh})
 441       or die(qq/Could not binmode() socket: '$!'\n/);
 442
 443     if ( $scheme eq 'https') {
 444         my $ssl_args = $self->_ssl_args($host);
 445         IO::Socket::SSL->start_SSL($self->{fh}, %$ssl_args);
 446         unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
 447             my $ssl_err = IO::Socket::SSL->errstr;
 448             die(qq/SSL connection failed for $host: $ssl_err\n/);
 449         }
 450     }
 451
 452     $self->{host} = $host;
 453     $self->{port} = $port;
 454
 455     return $self;
 456 }
 457
 458 sub close {
 459     @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
 460     my ($self) = @_;
 461     CORE::close($self->{fh})
 462       or die(qq/Could not close socket: '$!'\n/);
 463 }
 464
 465 sub write {
 466     @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
 467     my ($self, $buf) = @_;
 468
 469     if ( $] ge '5.008' ) {
 470         utf8::downgrade($buf, 1)
 471             or die(qq/Wide character in write()\n/);
 472     }
 473
 474     my $len = length $buf;
 475     my $off = 0;
 476
 477     local $SIG{PIPE} = 'IGNORE';
 478
 479     while () {
 480         $self->can_write
 481           or die(qq/Timed out while waiting for socket to become ready for writing\n/);
 482         my $r = syswrite($self->{fh}, $buf, $len, $off);
 483         if (defined $r) {
 484             $len -= $r;
 485             $off += $r;
 486             last unless $len > 0;
 487         }
 488         elsif ($! == EPIPE) {
 489             die(qq/Socket closed by remote server: $!\n/);
 490         }
 491         elsif ($! != EINTR) {
 492             die(qq/Could not write to socket: '$!'\n/);
 493         }
 494     }
 495     return $off;
 496 }
 497
 498 sub read {
 499     @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
 500     my ($self, $len, $allow_partial) = @_;
 501
 502     my $buf  = '';
 503     my $got = length $self->{rbuf};
 504
 505     if ($got) {
 506         my $take = ($got < $len) ? $got : $len;
 507         $buf  = substr($self->{rbuf}, 0, $take, '');
 508         $len -= $take;
 509     }
 510
 511     while ($len > 0) {
 512         $self->can_read
 513           or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
 514         my $r = sysread($self->{fh}, $buf, $len, length $buf);
 515         if (defined $r) {
 516             last unless $r;
 517             $len -= $r;
 518         }
 519         elsif ($! != EINTR) {
 520             die(qq/Could not read from socket: '$!'\n/);
 521         }
 522     }
 523     if ($len && !$allow_partial) {
 524         die(qq/Unexpected end of stream\n/);
 525     }
 526     return $buf;
 527 }
 528
 529 sub readline {
 530     @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
 531     my ($self) = @_;
 532
 533     while () {
 534         if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
 535             return $1;
 536         }
 537         if (length $self->{rbuf} >= $self->{max_line_size}) {
 538             die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
 539         }
 540         $self->can_read
 541           or die(qq/Timed out while waiting for socket to become ready for reading\n/);
 542         my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
 543         if (defined $r) {
 544             last unless $r;
 545         }
 546         elsif ($! != EINTR) {
 547             die(qq/Could not read from socket: '$!'\n/);
 548         }
 549     }
 550     die(qq/Unexpected end of stream while looking for line\n/);
 551 }
 552
 553 sub read_header_lines {
 554     @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
 555     my ($self, $headers) = @_;
 556     $headers ||= {};
 557     my $lines   = 0;
 558     my $val;
 559
 560     while () {
 561          my $line = $self->readline;
 562
 563          if (++$lines >= $self->{max_header_lines}) {
 564              die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
 565          }
 566          elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
 567              my ($field_name) = lc $1;
 568              if (exists $headers->{$field_name}) {
 569                  for ($headers->{$field_name}) {
 570                      $_ = [$_] unless ref $_ eq "ARRAY";
 571                      push @$_, $2;
 572                      $val = \$_->[-1];
 573                  }
 574              }
 575              else {
 576                  $val = \($headers->{$field_name} = $2);
 577              }
 578          }
 579          elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
 580              $val
 581                or die(qq/Unexpected header continuation line\n/);
 582              next unless length $1;
 583              $$val .= ' ' if length $$val;
 584              $$val .= $1;
 585          }
 586          elsif ($line =~ /\A \x0D?\x0A \z/x) {
 587             last;
 588          }
 589          else {
 590             die(q/Malformed header line: / . $Printable->($line) . "\n");
 591          }
 592     }
 593     return $headers;
 594 }
 595
 596 sub write_request {
 597     @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
 598     my($self, $request) = @_;
 599     $self->write_request_header(@{$request}{qw/method uri headers/});
 600     $self->write_body($request) if $request->{cb};
 601     return;
 602 }
 603
 604 my %HeaderCase = (
 605     'content-md5'      => 'Content-MD5',
 606     'etag'             => 'ETag',
 607     'te'               => 'TE',
 608     'www-authenticate' => 'WWW-Authenticate',
 609     'x-xss-protection' => 'X-XSS-Protection',
 610 );
 611
 612 sub write_header_lines {
 613     (@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n");
 614     my($self, $headers) = @_;
 615
 616     my $buf = '';
 617     while (my ($k, $v) = each %$headers) {
 618         my $field_name = lc $k;
 619         if (exists $HeaderCase{$field_name}) {
 620             $field_name = $HeaderCase{$field_name};
 621         }
 622         else {
 623             $field_name =~ /\A $Token+ \z/xo
 624               or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
 625             $field_name =~ s/\b(\w)/\u$1/g;
 626             $HeaderCase{lc $field_name} = $field_name;
 627         }
 628         for (ref $v eq 'ARRAY' ? @$v : $v) {
 629             /[^\x0D\x0A]/
 630               or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
 631             $buf .= "$field_name: $_\x0D\x0A";
 632         }
 633     }
 634     $buf .= "\x0D\x0A";
 635     return $self->write($buf);
 636 }
 637
 638 sub read_body {
 639     @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
 640     my ($self, $cb, $response) = @_;
 641     my $te = $response->{headers}{'transfer-encoding'} || '';
 642     if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
 643         $self->read_chunked_body($cb, $response);
 644     }
 645     else {
 646         $self->read_content_body($cb, $response);
 647     }
 648     return;
 649 }
 650
 651 sub write_body {
 652     @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
 653     my ($self, $request) = @_;
 654     if ($request->{headers}{'content-length'}) {
 655         return $self->write_content_body($request);
 656     }
 657     else {
 658         return $self->write_chunked_body($request);
 659     }
 660 }
 661
 662 sub read_content_body {
 663     @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
 664     my ($self, $cb, $response, $content_length) = @_;
 665     $content_length ||= $response->{headers}{'content-length'};
 666
 667     if ( $content_length ) {
 668         my $len = $content_length;
 669         while ($len > 0) {
 670             my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
 671             $cb->($self->read($read, 0), $response);
 672             $len -= $read;
 673         }
 674     }
 675     else {
 676         my $chunk;
 677         $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
 678     }
 679
 680     return;
 681 }
 682
 683 sub write_content_body {
 684     @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
 685     my ($self, $request) = @_;
 686
 687     my ($len, $content_length) = (0, $request->{headers}{'content-length'});
 688     while () {
 689         my $data = $request->{cb}->();
 690
 691         defined $data && length $data
 692           or last;
 693
 694         if ( $] ge '5.008' ) {
 695             utf8::downgrade($data, 1)
 696                 or die(qq/Wide character in write_content()\n/);
 697         }
 698
 699         $len += $self->write($data);
 700     }
 701
 702     $len == $content_length
 703       or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
 704
 705     return $len;
 706 }
 707
 708 sub read_chunked_body {
 709     @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
 710     my ($self, $cb, $response) = @_;
 711
 712     while () {
 713         my $head = $self->readline;
 714
 715         $head =~ /\A ([A-Fa-f0-9]+)/x
 716           or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
 717
 718         my $len = hex($1)
 719           or last;
 720
 721         $self->read_content_body($cb, $response, $len);
 722
 723         $self->read(2) eq "\x0D\x0A"
 724           or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
 725     }
 726     $self->read_header_lines($response->{headers});
 727     return;
 728 }
 729
 730 sub write_chunked_body {
 731     @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
 732     my ($self, $request) = @_;
 733
 734     my $len = 0;
 735     while () {
 736         my $data = $request->{cb}->();
 737
 738         defined $data && length $data
 739           or last;
 740
 741         if ( $] ge '5.008' ) {
 742             utf8::downgrade($data, 1)
 743                 or die(qq/Wide character in write_chunked_body()\n/);
 744         }
 745
 746         $len += length $data;
 747
 748         my $chunk  = sprintf '%X', length $data;
 749            $chunk .= "\x0D\x0A";
 750            $chunk .= $data;
 751            $chunk .= "\x0D\x0A";
 752
 753         $self->write($chunk);
 754     }
 755     $self->write("0\x0D\x0A");
 756     $self->write_header_lines($request->{trailer_cb}->())
 757         if ref $request->{trailer_cb} eq 'CODE';
 758     return $len;
 759 }
 760
 761 sub read_response_header {
 762     @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
 763     my ($self) = @_;
 764
 765     my $line = $self->readline;
 766
 767     $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
 768       or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
 769
 770     my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
 771
 772     die (qq/Unsupported HTTP protocol: $protocol\n/)
 773         unless $version =~ /0*1\.0*[01]/;
 774
 775     return {
 776         status   => $status,
 777         reason   => $reason,
 778         headers  => $self->read_header_lines,
 779         protocol => $protocol,
 780     };
 781 }
 782
 783 sub write_request_header {
 784     @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
 785     my ($self, $method, $request_uri, $headers) = @_;
 786
 787     return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
 788          + $self->write_header_lines($headers);
 789 }
 790
 791 sub _do_timeout {
 792     my ($self, $type, $timeout) = @_;
 793     $timeout = $self->{timeout}
 794         unless defined $timeout && $timeout >= 0;
 795
 796     my $fd = fileno $self->{fh};
 797     defined $fd && $fd >= 0
 798       or die(qq/select(2): 'Bad file descriptor'\n/);
 799
 800     my $initial = time;
 801     my $pending = $timeout;
 802     my $nfound;
 803
 804     vec(my $fdset = '', $fd, 1) = 1;
 805
 806     while () {
 807         $nfound = ($type eq 'read')
 808             ? select($fdset, undef, undef, $pending)
 809             : select(undef, $fdset, undef, $pending) ;
 810         if ($nfound == -1) {
 811             $! == EINTR
 812               or die(qq/select(2): '$!'\n/);
 813             redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
 814             $nfound = 0;
 815         }
 816         last;
 817     }
 818     $! = 0;
 819     return $nfound;
 820 }
 821
 822 sub can_read {
 823     @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
 824     my $self = shift;
 825     return $self->_do_timeout('read', @_)
 826 }
 827
 828 sub can_write {
 829     @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
 830     my $self = shift;
 831     return $self->_do_timeout('write', @_)
 832 }
 833
 834 # Try to find a CA bundle to validate the SSL cert,
 835 # prefer Mozilla::CA or fallback to a system file
 836 sub _find_CA_file {
 837     return Mozilla::CA::SSL_ca_file()
 838         if eval { require Mozilla::CA };
 839
 840     foreach my $ca_bundle (qw{
 841         /etc/ssl/certs/ca-certificates.crt
 842         /etc/pki/tls/certs/ca-bundle.crt
 843         /etc/ssl/ca-bundle.pem
 844         }
 845     ) {
 846         return $ca_bundle if -e $ca_bundle;
 847     }
 848
 849     die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
 850       . qq/Try installing Mozilla::CA from CPAN\n/;
 851 }
 852
 853 sub _ssl_args {
 854     my ($self, $host) = @_;
 855
 856     my %ssl_args = (
 857         SSL_hostname        => $host,  # SNI
 858     );
 859
 860     if ($self->{verify_SSL}) {
 861         $ssl_args{SSL_verifycn_scheme}  = 'http'; # enable CN validation
 862         $ssl_args{SSL_verifycn_name}    = $host;  # set validation hostname
 863         $ssl_args{SSL_verify_mode}      = 0x01;   # enable cert validation
 864         $ssl_args{SSL_ca_file}          = $self->_find_CA_file;
 865     }
 866     else {
 867         $ssl_args{SSL_verifycn_scheme}  = 'none'; # disable CN validation
 868         $ssl_args{SSL_verify_mode}      = 0x00;   # disable cert validation
 869     }
 870
 871     # user options override settings from verify_SSL
 872     for my $k ( keys %{$self->{SSL_options}} ) {
 873         $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
 874     }
 875
 876     return \%ssl_args;
 877 }
 878
 879 1;
 880
 881
 882
 883 __END__
 884 =pod
 885
 886 =head1 NAME
 887
 888 HTTP::Tiny - A small, simple, correct HTTP/1.1 client
 889
 890 =head1 VERSION
 891
 892 version 0.022
 893
 894 =head1 SYNOPSIS
 895
 896     use HTTP::Tiny;
 897
 898     my $response = HTTP::Tiny->new->get('http://example.com/');
 899
 900     die "Failed!\n" unless $response->{success};
 901
 902     print "$response->{status} $response->{reason}\n";
 903
 904     while (my ($k, $v) = each %{$response->{headers}}) {
 905         for (ref $v eq 'ARRAY' ? @$v : $v) {
 906             print "$k: $_\n";
 907         }
 908     }
 909
 910     print $response->{content} if length $response->{content};
 911
 912 =head1 DESCRIPTION
 913
 914 This is a very simple HTTP/1.1 client, designed for doing simple GET
 915 requests without the overhead of a large framework like L<LWP::UserAgent>.
 916
 917 It is more correct and more complete than L<HTTP::Lite>.  It supports
 918 proxies (currently only non-authenticating ones) and redirection.  It
 919 also correctly resumes after EINTR.
 920
 921 =head1 METHODS
 922
 923 =head2 new
 924
 925     $http = HTTP::Tiny->new( %attributes );
 926
 927 This constructor returns a new HTTP::Tiny object.  Valid attributes include:
 928
 929 =over 4
 930
 931 =item *
 932
 933 C<agent>
 934
 935 A user-agent string (defaults to 'HTTP::Tiny/$VERSION')
 936
 937 =item *
 938
 939 C<default_headers>
 940
 941 A hashref of default headers to apply to requests
 942
 943 =item *
 944
 945 C<local_address>
 946
 947 The local IP address to bind to
 948
 949 =item *
 950
 951 C<max_redirect>
 952
 953 Maximum number of redirects allowed (defaults to 5)
 954
 955 =item *
 956
 957 C<max_size>
 958
 959 Maximum response size (only when not using a data callback).  If defined,
 960 responses larger than this will return an exception.
 961
 962 =item *
 963
 964 C<proxy>
 965
 966 URL of a proxy server to use (default is C<$ENV{http_proxy}> if set)
 967
 968 =item *
 969
 970 C<timeout>
 971
 972 Request timeout in seconds (default is 60)
 973
 974 =item *
 975
 976 C<verify_SSL>
 977
 978 A boolean that indicates whether to validate the SSL certificate of an C<https>
 979 connection (default is false)
 980
 981 =item *
 982
 983 C<SSL_options>
 984
 985 A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
 986
 987 =back
 988
 989 Exceptions from C<max_size>, C<timeout> or other errors will result in a
 990 pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
 991 content field in the response will contain the text of the exception.
 992
 993 See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
 994
 995 =head2 get|head|put|post|delete
 996
 997     $response = $http->get($url);
 998     $response = $http->get($url, \%options);
 999     $response = $http->head($url);
1000
1001 These methods are shorthand for calling C<request()> for the given method.  The
1002 URL must have unsafe characters escaped and international domain names encoded.
1003 See C<request()> for valid options and a description of the response.
1004
1005 The C<success> field of the response will be true if the status code is 2XX.
1006
1007 =head2 post_form
1008
1009     $response = $http->post_form($url, $form_data);
1010     $response = $http->post_form($url, $form_data, \%options);
1011
1012 This method executes a C<POST> request and sends the key/value pairs from a
1013 form data hash or array reference to the given URL with a C<content-type> of
1014 C<application/x-www-form-urlencoded>.  See documentation for the
1015 C<www_form_urlencode> method for details on the encoding.
1016
1017 The URL must have unsafe characters escaped and international domain names
1018 encoded.  See C<request()> for valid options and a description of the response.
1019 Any C<content-type> header or content in the options hashref will be ignored.
1020
1021 The C<success> field of the response will be true if the status code is 2XX.
1022
1023 =head2 mirror
1024
1025     $response = $http->mirror($url, $file, \%options)
1026     if ( $response->{success} ) {
1027         print "$file is up to date\n";
1028     }
1029
1030 Executes a C<GET> request for the URL and saves the response body to the file
1031 name provided.  The URL must have unsafe characters escaped and international
1032 domain names encoded.  If the file already exists, the request will includes an
1033 C<If-Modified-Since> header with the modification timestamp of the file.  You
1034 may specify a different C<If-Modified-Since> header yourself in the C<<
1035 $options->{headers} >> hash.
1036
1037 The C<success> field of the response will be true if the status code is 2XX
1038 or if the status code is 304 (unmodified).
1039
1040 If the file was modified and the server response includes a properly
1041 formatted C<Last-Modified> header, the file modification time will
1042 be updated accordingly.
1043
1044 =head2 request
1045
1046     $response = $http->request($method, $url);
1047     $response = $http->request($method, $url, \%options);
1048
1049 Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
1050 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
1051 international domain names encoded.  A hashref of options may be appended to
1052 modify the request.
1053
1054 Valid options are:
1055
1056 =over 4
1057
1058 =item *
1059
1060 C<headers>
1061
1062 A hashref containing headers to include with the request.  If the value for
1063 a header is an array reference, the header will be output multiple times with
1064 each value in the array.  These headers over-write any default headers.
1065
1066 =item *
1067
1068 C<content>
1069
1070 A scalar to include as the body of the request OR a code reference
1071 that will be called iteratively to produce the body of the request
1072
1073 =item *
1074
1075 C<trailer_callback>
1076
1077 A code reference that will be called if it exists to provide a hashref
1078 of trailing headers (only used with chunked transfer-encoding)
1079
1080 =item *
1081
1082 C<data_callback>
1083
1084 A code reference that will be called for each chunks of the response
1085 body received.
1086
1087 =back
1088
1089 If the C<content> option is a code reference, it will be called iteratively
1090 to provide the content body of the request.  It should return the empty
1091 string or undef when the iterator is exhausted.
1092
1093 If the C<data_callback> option is provided, it will be called iteratively until
1094 the entire response body is received.  The first argument will be a string
1095 containing a chunk of the response body, the second argument will be the
1096 in-progress response hash reference, as described below.  (This allows
1097 customizing the action of the callback based on the C<status> or C<headers>
1098 received prior to the content body.)
1099
1100 The C<request> method returns a hashref containing the response.  The hashref
1101 will have the following keys:
1102
1103 =over 4
1104
1105 =item *
1106
1107 C<success>
1108
1109 Boolean indicating whether the operation returned a 2XX status code
1110
1111 =item *
1112
1113 C<url>
1114
1115 URL that provided the response. This is the URL of the request unless
1116 there were redirections, in which case it is the last URL queried
1117 in a redirection chain
1118
1119 =item *
1120
1121 C<status>
1122
1123 The HTTP status code of the response
1124
1125 =item *
1126
1127 C<reason>
1128
1129 The response phrase returned by the server
1130
1131 =item *
1132
1133 C<content>
1134
1135 The body of the response.  If the response does not have any content
1136 or if a data callback is provided to consume the response body,
1137 this will be the empty string
1138
1139 =item *
1140
1141 C<headers>
1142
1143 A hashref of header fields.  All header field names will be normalized
1144 to be lower case. If a header is repeated, the value will be an arrayref;
1145 it will otherwise be a scalar string containing the value
1146
1147 =back
1148
1149 On an exception during the execution of the request, the C<status> field will
1150 contain 599, and the C<content> field will contain the text of the exception.
1151
1152 =head2 www_form_urlencode
1153
1154     $params = $http->www_form_urlencode( $data );
1155     $response = $http->get("http://example.com/query?$params");
1156
1157 This method converts the key/value pairs from a data hash or array reference
1158 into a C<x-www-form-urlencoded> string.  The keys and values from the data
1159 reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
1160 array reference, the key will be repeated with each of the values of the array
1161 reference.  The key/value pairs in the resulting string will be sorted by key
1162 and value.
1163
1164 =for Pod::Coverage agent
1165 default_headers
1166 local_address
1167 max_redirect
1168 max_size
1169 proxy
1170 timeout
1171 verify_SSL
1172 SSL_options
1173
1174 =head1 SSL SUPPORT
1175
1176 Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
1177 greater is installed. An exception will be thrown if a new enough
1178 IO::Socket::SSL is not installed or if the SSL encryption fails. There is no
1179 support for C<https> connections via proxy (i.e. RFC 2817).
1180
1181 SSL provides two distinct capabilities:
1182
1183 =over 4
1184
1185 =item *
1186
1187 Encrypted communication channel
1188
1189 =item *
1190
1191 Verification of server identity
1192
1193 =back
1194
1195 B<By default, HTTP::Tiny does not verify server identity>.
1196
1197 Server identity verification is controversial and potentially tricky because it
1198 depends on a (usually paid) third-party Certificate Authority (CA) trust model
1199 to validate a certificate as legitimate.  This discriminates against servers
1200 with self-signed certificates or certificates signed by free, community-driven
1201 CA's such as L<CAcert.org|http://cacert.org>.
1202
1203 By default, HTTP::Tiny does not make any assumptions about your trust model,
1204 threat level or risk tolerance.  It just aims to give you an encrypted channel
1205 when you need one.
1206
1207 Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify
1208 that an SSL connection has a valid SSL certificate corresponding to the host
1209 name of the connection and that the SSL certificate has been verified by a CA.
1210 Assuming you trust the CA, this will protect against a L<man-in-the-middle
1211 attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>.  If you are
1212 concerned about security, you should enable this option.
1213
1214 Certificate verification requires a file containing trusted CA certificates.
1215 If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
1216 included with it as a source of trusted CA's.  (This means you trust Mozilla,
1217 the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
1218 toolchain used to install it, and your operating system security, right?)
1219
1220 If that module is not available, then HTTP::Tiny will search several
1221 system-specific default locations for a CA certificate file:
1222
1223 =over 4
1224
1225 =item *
1226
1227 /etc/ssl/certs/ca-certificates.crt
1228
1229 =item *
1230
1231 /etc/pki/tls/certs/ca-bundle.crt
1232
1233 =item *
1234
1235 /etc/ssl/ca-bundle.pem
1236
1237 =back
1238
1239 An exception will be raised if C<verify_SSL> is true and no CA certificate file
1240 is available.
1241
1242 If you desire complete control over SSL connections, the C<SSL_options> attribute
1243 lets you provide a hash reference that will be passed through to
1244 C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
1245 example, to provide your own trusted CA file:
1246
1247     SSL_options => {
1248         SSL_ca_file => $file_path,
1249     }
1250
1251 The C<SSL_options> attribute could also be used for such things as providing a
1252 client certificate for authentication to a server or controlling the choice of
1253 cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for
1254 details.
1255
1256 =head1 LIMITATIONS
1257
1258 HTTP::Tiny is I<conditionally compliant> with the
1259 L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
1260 It attempts to meet all "MUST" requirements of the specification, but does not
1261 implement all "SHOULD" requirements.
1262
1263 Some particular limitations of note include:
1264
1265 =over
1266
1267 =item *
1268
1269 HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
1270 that user-defined headers and content are compliant with the HTTP/1.1
1271 specification.
1272
1273 =item *
1274
1275 Users must ensure that URLs are properly escaped for unsafe characters and that
1276 international domain names are properly encoded to ASCII. See L<URI::Escape>,
1277 L<URI::_punycode> and L<Net::IDN::Encode>.
1278
1279 =item *
1280
1281 Redirection is very strict against the specification.  Redirection is only
1282 automatic for response codes 301, 302 and 307 if the request method is 'GET' or
1283 'HEAD'.  Response code 303 is always converted into a 'GET' redirection, as
1284 mandated by the specification.  There is no automatic support for status 305
1285 ("Use proxy") redirections.
1286
1287 =item *
1288
1289 Persistent connections are not supported.  The C<Connection> header will
1290 always be set to C<close>.
1291
1292 =item *
1293
1294 Cookies are not directly supported.  Users that set a C<Cookie> header
1295 should also set C<max_redirect> to zero to ensure cookies are not
1296 inappropriately re-transmitted.
1297
1298 =item *
1299
1300 Only the C<http_proxy> environment variable is supported in the format
1301 C<http://HOST:PORT/>.  If a C<proxy> argument is passed to C<new> (including
1302 undef), then the C<http_proxy> environment variable is ignored.
1303
1304 =item *
1305
1306 There is no provision for delaying a request body using an C<Expect> header.
1307 Unexpected C<1XX> responses are silently ignored as per the specification.
1308
1309 =item *
1310
1311 Only 'chunked' C<Transfer-Encoding> is supported.
1312
1313 =item *
1314
1315 There is no support for a Request-URI of '*' for the 'OPTIONS' request.
1316
1317 =item *
1318
1319 There is no support for IPv6 of any kind.
1320
1321 =back
1322
1323 =head1 SEE ALSO
1324
1325 =over 4
1326
1327 =item *
1328
1329 L<LWP::UserAgent>
1330
1331 =item *
1332
1333 L<IO::Socket::SSL>
1334
1335 =item *
1336
1337 L<Mozilla::CA>
1338
1339 =back
1340
1341 =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
1342
1343 =head1 SUPPORT
1344
1345 =head2 Bugs / Feature Requests
1346
1347 Please report any bugs or feature requests through the issue tracker
1348 at L<http://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny>.
1349 You will be notified automatically of any progress on your issue.
1350
1351 =head2 Source Code
1352
1353 This is open source software.  The code repository is available for
1354 public review and contribution under the terms of the license.
1355
1356 L<https://github.com/dagolden/p5-http-tiny>
1357
1358   git clone https://github.com/dagolden/p5-http-tiny.git
1359
1360 =head1 AUTHORS
1361
1362 =over 4
1363
1364 =item *
1365
1366 Christian Hansen <chansen@cpan.org>
1367
1368 =item *
1369
1370 David Golden <dagolden@cpan.org>
1371
1372 =item *
1373
1374 Mike Doherty <doherty@cpan.org>
1375
1376 =back
1377
1378 =head1 COPYRIGHT AND LICENSE
1379
1380 This software is copyright (c) 2012 by Christian Hansen.
1381
1382 This is free software; you can redistribute it and/or modify it under
1383 the same terms as the Perl 5 programming language system itself.
1384
1385 =cut
1386