This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update HTTP-Tiny to CPAN version 0.024
[perl5.git] / 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.024'; # 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         die(qq/Net::SSLeay 1.49 must be installed for https support\n/)
427             unless eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)};
428     }
429     elsif ( $scheme ne 'http' ) {
430       die(qq/Unsupported URL scheme '$scheme'\n/);
431     }
432     $self->{fh} = 'IO::Socket::INET'->new(
433         PeerHost  => $host,
434         PeerPort  => $port,
435         $self->{local_address} ?
436             ( LocalAddr => $self->{local_address} ) : (),
437         Proto     => 'tcp',
438         Type      => SOCK_STREAM,
439         Timeout   => $self->{timeout}
440     ) or die(qq/Could not connect to '$host:$port': $@\n/);
441
442     binmode($self->{fh})
443       or die(qq/Could not binmode() socket: '$!'\n/);
444
445     if ( $scheme eq 'https') {
446         my $ssl_args = $self->_ssl_args($host);
447         IO::Socket::SSL->start_SSL(
448             $self->{fh},
449             %$ssl_args,
450             SSL_create_ctx_callback => sub {
451                 my $ctx = shift;
452                 Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
453             },
454         );
455
456         unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
457             my $ssl_err = IO::Socket::SSL->errstr;
458             die(qq/SSL connection failed for $host: $ssl_err\n/);
459         }
460     }
461
462     $self->{host} = $host;
463     $self->{port} = $port;
464
465     return $self;
466 }
467
468 sub close {
469     @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
470     my ($self) = @_;
471     CORE::close($self->{fh})
472       or die(qq/Could not close socket: '$!'\n/);
473 }
474
475 sub write {
476     @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
477     my ($self, $buf) = @_;
478
479     if ( $] ge '5.008' ) {
480         utf8::downgrade($buf, 1)
481             or die(qq/Wide character in write()\n/);
482     }
483
484     my $len = length $buf;
485     my $off = 0;
486
487     local $SIG{PIPE} = 'IGNORE';
488
489     while () {
490         $self->can_write
491           or die(qq/Timed out while waiting for socket to become ready for writing\n/);
492         my $r = syswrite($self->{fh}, $buf, $len, $off);
493         if (defined $r) {
494             $len -= $r;
495             $off += $r;
496             last unless $len > 0;
497         }
498         elsif ($! == EPIPE) {
499             die(qq/Socket closed by remote server: $!\n/);
500         }
501         elsif ($! != EINTR) {
502             if ($self->{fh}->can('errstr')){
503                 my $err = $self->{fh}->errstr();
504                 die (qq/Could not write to SSL socket: '$err'\n /);
505             }
506             else {
507                 die(qq/Could not write to socket: '$!'\n/);
508             }
509
510         }
511     }
512     return $off;
513 }
514
515 sub read {
516     @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
517     my ($self, $len, $allow_partial) = @_;
518
519     my $buf  = '';
520     my $got = length $self->{rbuf};
521
522     if ($got) {
523         my $take = ($got < $len) ? $got : $len;
524         $buf  = substr($self->{rbuf}, 0, $take, '');
525         $len -= $take;
526     }
527
528     while ($len > 0) {
529         $self->can_read
530           or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
531         my $r = sysread($self->{fh}, $buf, $len, length $buf);
532         if (defined $r) {
533             last unless $r;
534             $len -= $r;
535         }
536         elsif ($! != EINTR) {
537             if ($self->{fh}->can('errstr')){
538                 my $err = $self->{fh}->errstr();
539                 die (qq/Could not read from SSL socket: '$err'\n /);
540             }
541             else {
542                 die(qq/Could not read from socket: '$!'\n/);
543             }
544         }
545     }
546     if ($len && !$allow_partial) {
547         die(qq/Unexpected end of stream\n/);
548     }
549     return $buf;
550 }
551
552 sub readline {
553     @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
554     my ($self) = @_;
555
556     while () {
557         if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
558             return $1;
559         }
560         if (length $self->{rbuf} >= $self->{max_line_size}) {
561             die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
562         }
563         $self->can_read
564           or die(qq/Timed out while waiting for socket to become ready for reading\n/);
565         my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
566         if (defined $r) {
567             last unless $r;
568         }
569         elsif ($! != EINTR) {
570             if ($self->{fh}->can('errstr')){
571                 my $err = $self->{fh}->errstr();
572                 die (qq/Could not read from SSL socket: '$err'\n /);
573             }
574             else {
575                 die(qq/Could not read from socket: '$!'\n/);
576             }
577         }
578     }
579     die(qq/Unexpected end of stream while looking for line\n/);
580 }
581
582 sub read_header_lines {
583     @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
584     my ($self, $headers) = @_;
585     $headers ||= {};
586     my $lines   = 0;
587     my $val;
588
589     while () {
590          my $line = $self->readline;
591
592          if (++$lines >= $self->{max_header_lines}) {
593              die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
594          }
595          elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
596              my ($field_name) = lc $1;
597              if (exists $headers->{$field_name}) {
598                  for ($headers->{$field_name}) {
599                      $_ = [$_] unless ref $_ eq "ARRAY";
600                      push @$_, $2;
601                      $val = \$_->[-1];
602                  }
603              }
604              else {
605                  $val = \($headers->{$field_name} = $2);
606              }
607          }
608          elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
609              $val
610                or die(qq/Unexpected header continuation line\n/);
611              next unless length $1;
612              $$val .= ' ' if length $$val;
613              $$val .= $1;
614          }
615          elsif ($line =~ /\A \x0D?\x0A \z/x) {
616             last;
617          }
618          else {
619             die(q/Malformed header line: / . $Printable->($line) . "\n");
620          }
621     }
622     return $headers;
623 }
624
625 sub write_request {
626     @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
627     my($self, $request) = @_;
628     $self->write_request_header(@{$request}{qw/method uri headers/});
629     $self->write_body($request) if $request->{cb};
630     return;
631 }
632
633 my %HeaderCase = (
634     'content-md5'      => 'Content-MD5',
635     'etag'             => 'ETag',
636     'te'               => 'TE',
637     'www-authenticate' => 'WWW-Authenticate',
638     'x-xss-protection' => 'X-XSS-Protection',
639 );
640
641 sub write_header_lines {
642     (@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n");
643     my($self, $headers) = @_;
644
645     my $buf = '';
646     while (my ($k, $v) = each %$headers) {
647         my $field_name = lc $k;
648         if (exists $HeaderCase{$field_name}) {
649             $field_name = $HeaderCase{$field_name};
650         }
651         else {
652             $field_name =~ /\A $Token+ \z/xo
653               or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
654             $field_name =~ s/\b(\w)/\u$1/g;
655             $HeaderCase{lc $field_name} = $field_name;
656         }
657         for (ref $v eq 'ARRAY' ? @$v : $v) {
658             /[^\x0D\x0A]/
659               or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
660             $buf .= "$field_name: $_\x0D\x0A";
661         }
662     }
663     $buf .= "\x0D\x0A";
664     return $self->write($buf);
665 }
666
667 sub read_body {
668     @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
669     my ($self, $cb, $response) = @_;
670     my $te = $response->{headers}{'transfer-encoding'} || '';
671     if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
672         $self->read_chunked_body($cb, $response);
673     }
674     else {
675         $self->read_content_body($cb, $response);
676     }
677     return;
678 }
679
680 sub write_body {
681     @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
682     my ($self, $request) = @_;
683     if ($request->{headers}{'content-length'}) {
684         return $self->write_content_body($request);
685     }
686     else {
687         return $self->write_chunked_body($request);
688     }
689 }
690
691 sub read_content_body {
692     @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
693     my ($self, $cb, $response, $content_length) = @_;
694     $content_length ||= $response->{headers}{'content-length'};
695
696     if ( $content_length ) {
697         my $len = $content_length;
698         while ($len > 0) {
699             my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
700             $cb->($self->read($read, 0), $response);
701             $len -= $read;
702         }
703     }
704     else {
705         my $chunk;
706         $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
707     }
708
709     return;
710 }
711
712 sub write_content_body {
713     @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
714     my ($self, $request) = @_;
715
716     my ($len, $content_length) = (0, $request->{headers}{'content-length'});
717     while () {
718         my $data = $request->{cb}->();
719
720         defined $data && length $data
721           or last;
722
723         if ( $] ge '5.008' ) {
724             utf8::downgrade($data, 1)
725                 or die(qq/Wide character in write_content()\n/);
726         }
727
728         $len += $self->write($data);
729     }
730
731     $len == $content_length
732       or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
733
734     return $len;
735 }
736
737 sub read_chunked_body {
738     @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
739     my ($self, $cb, $response) = @_;
740
741     while () {
742         my $head = $self->readline;
743
744         $head =~ /\A ([A-Fa-f0-9]+)/x
745           or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
746
747         my $len = hex($1)
748           or last;
749
750         $self->read_content_body($cb, $response, $len);
751
752         $self->read(2) eq "\x0D\x0A"
753           or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
754     }
755     $self->read_header_lines($response->{headers});
756     return;
757 }
758
759 sub write_chunked_body {
760     @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
761     my ($self, $request) = @_;
762
763     my $len = 0;
764     while () {
765         my $data = $request->{cb}->();
766
767         defined $data && length $data
768           or last;
769
770         if ( $] ge '5.008' ) {
771             utf8::downgrade($data, 1)
772                 or die(qq/Wide character in write_chunked_body()\n/);
773         }
774
775         $len += length $data;
776
777         my $chunk  = sprintf '%X', length $data;
778            $chunk .= "\x0D\x0A";
779            $chunk .= $data;
780            $chunk .= "\x0D\x0A";
781
782         $self->write($chunk);
783     }
784     $self->write("0\x0D\x0A");
785     $self->write_header_lines($request->{trailer_cb}->())
786         if ref $request->{trailer_cb} eq 'CODE';
787     return $len;
788 }
789
790 sub read_response_header {
791     @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
792     my ($self) = @_;
793
794     my $line = $self->readline;
795
796     $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
797       or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
798
799     my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
800
801     die (qq/Unsupported HTTP protocol: $protocol\n/)
802         unless $version =~ /0*1\.0*[01]/;
803
804     return {
805         status   => $status,
806         reason   => $reason,
807         headers  => $self->read_header_lines,
808         protocol => $protocol,
809     };
810 }
811
812 sub write_request_header {
813     @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
814     my ($self, $method, $request_uri, $headers) = @_;
815
816     return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
817          + $self->write_header_lines($headers);
818 }
819
820 sub _do_timeout {
821     my ($self, $type, $timeout) = @_;
822     $timeout = $self->{timeout}
823         unless defined $timeout && $timeout >= 0;
824
825     my $fd = fileno $self->{fh};
826     defined $fd && $fd >= 0
827       or die(qq/select(2): 'Bad file descriptor'\n/);
828
829     my $initial = time;
830     my $pending = $timeout;
831     my $nfound;
832
833     vec(my $fdset = '', $fd, 1) = 1;
834
835     while () {
836         $nfound = ($type eq 'read')
837             ? select($fdset, undef, undef, $pending)
838             : select(undef, $fdset, undef, $pending) ;
839         if ($nfound == -1) {
840             $! == EINTR
841               or die(qq/select(2): '$!'\n/);
842             redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
843             $nfound = 0;
844         }
845         last;
846     }
847     $! = 0;
848     return $nfound;
849 }
850
851 sub can_read {
852     @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
853     my $self = shift;
854     return $self->_do_timeout('read', @_)
855 }
856
857 sub can_write {
858     @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
859     my $self = shift;
860     return $self->_do_timeout('write', @_)
861 }
862
863 # Try to find a CA bundle to validate the SSL cert,
864 # prefer Mozilla::CA or fallback to a system file
865 sub _find_CA_file {
866     my $self = shift();
867
868     return $self->{SSL_options}->{SSL_ca_file}
869         if $self->{SSL_options}->{SSL_ca_file} and -e $self->{SSL_options}->{SSL_ca_file};
870
871     return Mozilla::CA::SSL_ca_file()
872         if eval { require Mozilla::CA };
873
874     foreach my $ca_bundle (qw{
875         /etc/ssl/certs/ca-certificates.crt
876         /etc/pki/tls/certs/ca-bundle.crt
877         /etc/ssl/ca-bundle.pem
878         }
879     ) {
880         return $ca_bundle if -e $ca_bundle;
881     }
882
883     die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
884       . qq/Try installing Mozilla::CA from CPAN\n/;
885 }
886
887 sub _ssl_args {
888     my ($self, $host) = @_;
889
890     my %ssl_args = (
891         SSL_hostname        => $host,  # SNI
892     );
893
894     if ($self->{verify_SSL}) {
895         $ssl_args{SSL_verifycn_scheme}  = 'http'; # enable CN validation
896         $ssl_args{SSL_verifycn_name}    = $host;  # set validation hostname
897         $ssl_args{SSL_verify_mode}      = 0x01;   # enable cert validation
898         $ssl_args{SSL_ca_file}          = $self->_find_CA_file;
899     }
900     else {
901         $ssl_args{SSL_verifycn_scheme}  = 'none'; # disable CN validation
902         $ssl_args{SSL_verify_mode}      = 0x00;   # disable cert validation
903     }
904
905     # user options override settings from verify_SSL
906     for my $k ( keys %{$self->{SSL_options}} ) {
907         $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
908     }
909
910     return \%ssl_args;
911 }
912
913 1;
914
915 __END__
916
917 =pod
918
919 =head1 NAME
920
921 HTTP::Tiny - A small, simple, correct HTTP/1.1 client
922
923 =head1 VERSION
924
925 version 0.024
926
927 =head1 SYNOPSIS
928
929     use HTTP::Tiny;
930
931     my $response = HTTP::Tiny->new->get('http://example.com/');
932
933     die "Failed!\n" unless $response->{success};
934
935     print "$response->{status} $response->{reason}\n";
936
937     while (my ($k, $v) = each %{$response->{headers}}) {
938         for (ref $v eq 'ARRAY' ? @$v : $v) {
939             print "$k: $_\n";
940         }
941     }
942
943     print $response->{content} if length $response->{content};
944
945 =head1 DESCRIPTION
946
947 This is a very simple HTTP/1.1 client, designed for doing simple GET
948 requests without the overhead of a large framework like L<LWP::UserAgent>.
949
950 It is more correct and more complete than L<HTTP::Lite>.  It supports
951 proxies (currently only non-authenticating ones) and redirection.  It
952 also correctly resumes after EINTR.
953
954 =head1 METHODS
955
956 =head2 new
957
958     $http = HTTP::Tiny->new( %attributes );
959
960 This constructor returns a new HTTP::Tiny object.  Valid attributes include:
961
962 =over 4
963
964 =item *
965
966 C<agent>
967
968 A user-agent string (defaults to 'HTTP::Tiny/$VERSION')
969
970 =item *
971
972 C<default_headers>
973
974 A hashref of default headers to apply to requests
975
976 =item *
977
978 C<local_address>
979
980 The local IP address to bind to
981
982 =item *
983
984 C<max_redirect>
985
986 Maximum number of redirects allowed (defaults to 5)
987
988 =item *
989
990 C<max_size>
991
992 Maximum response size (only when not using a data callback).  If defined,
993 responses larger than this will return an exception.
994
995 =item *
996
997 C<proxy>
998
999 URL of a proxy server to use (default is C<$ENV{http_proxy}> if set)
1000
1001 =item *
1002
1003 C<timeout>
1004
1005 Request timeout in seconds (default is 60)
1006
1007 =item *
1008
1009 C<verify_SSL>
1010
1011 A boolean that indicates whether to validate the SSL certificate of an C<https>
1012 connection (default is false)
1013
1014 =item *
1015
1016 C<SSL_options>
1017
1018 A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
1019
1020 =back
1021
1022 Exceptions from C<max_size>, C<timeout> or other errors will result in a
1023 pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
1024 content field in the response will contain the text of the exception.
1025
1026 See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
1027
1028 =head2 get|head|put|post|delete
1029
1030     $response = $http->get($url);
1031     $response = $http->get($url, \%options);
1032     $response = $http->head($url);
1033
1034 These methods are shorthand for calling C<request()> for the given method.  The
1035 URL must have unsafe characters escaped and international domain names encoded.
1036 See C<request()> for valid options and a description of the response.
1037
1038 The C<success> field of the response will be true if the status code is 2XX.
1039
1040 =head2 post_form
1041
1042     $response = $http->post_form($url, $form_data);
1043     $response = $http->post_form($url, $form_data, \%options);
1044
1045 This method executes a C<POST> request and sends the key/value pairs from a
1046 form data hash or array reference to the given URL with a C<content-type> of
1047 C<application/x-www-form-urlencoded>.  See documentation for the
1048 C<www_form_urlencode> method for details on the encoding.
1049
1050 The URL must have unsafe characters escaped and international domain names
1051 encoded.  See C<request()> for valid options and a description of the response.
1052 Any C<content-type> header or content in the options hashref will be ignored.
1053
1054 The C<success> field of the response will be true if the status code is 2XX.
1055
1056 =head2 mirror
1057
1058     $response = $http->mirror($url, $file, \%options)
1059     if ( $response->{success} ) {
1060         print "$file is up to date\n";
1061     }
1062
1063 Executes a C<GET> request for the URL and saves the response body to the file
1064 name provided.  The URL must have unsafe characters escaped and international
1065 domain names encoded.  If the file already exists, the request will includes an
1066 C<If-Modified-Since> header with the modification timestamp of the file.  You
1067 may specify a different C<If-Modified-Since> header yourself in the C<<
1068 $options->{headers} >> hash.
1069
1070 The C<success> field of the response will be true if the status code is 2XX
1071 or if the status code is 304 (unmodified).
1072
1073 If the file was modified and the server response includes a properly
1074 formatted C<Last-Modified> header, the file modification time will
1075 be updated accordingly.
1076
1077 =head2 request
1078
1079     $response = $http->request($method, $url);
1080     $response = $http->request($method, $url, \%options);
1081
1082 Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
1083 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
1084 international domain names encoded.  A hashref of options may be appended to
1085 modify the request.
1086
1087 Valid options are:
1088
1089 =over 4
1090
1091 =item *
1092
1093 C<headers>
1094
1095 A hashref containing headers to include with the request.  If the value for
1096 a header is an array reference, the header will be output multiple times with
1097 each value in the array.  These headers over-write any default headers.
1098
1099 =item *
1100
1101 C<content>
1102
1103 A scalar to include as the body of the request OR a code reference
1104 that will be called iteratively to produce the body of the request
1105
1106 =item *
1107
1108 C<trailer_callback>
1109
1110 A code reference that will be called if it exists to provide a hashref
1111 of trailing headers (only used with chunked transfer-encoding)
1112
1113 =item *
1114
1115 C<data_callback>
1116
1117 A code reference that will be called for each chunks of the response
1118 body received.
1119
1120 =back
1121
1122 If the C<content> option is a code reference, it will be called iteratively
1123 to provide the content body of the request.  It should return the empty
1124 string or undef when the iterator is exhausted.
1125
1126 If the C<data_callback> option is provided, it will be called iteratively until
1127 the entire response body is received.  The first argument will be a string
1128 containing a chunk of the response body, the second argument will be the
1129 in-progress response hash reference, as described below.  (This allows
1130 customizing the action of the callback based on the C<status> or C<headers>
1131 received prior to the content body.)
1132
1133 The C<request> method returns a hashref containing the response.  The hashref
1134 will have the following keys:
1135
1136 =over 4
1137
1138 =item *
1139
1140 C<success>
1141
1142 Boolean indicating whether the operation returned a 2XX status code
1143
1144 =item *
1145
1146 C<url>
1147
1148 URL that provided the response. This is the URL of the request unless
1149 there were redirections, in which case it is the last URL queried
1150 in a redirection chain
1151
1152 =item *
1153
1154 C<status>
1155
1156 The HTTP status code of the response
1157
1158 =item *
1159
1160 C<reason>
1161
1162 The response phrase returned by the server
1163
1164 =item *
1165
1166 C<content>
1167
1168 The body of the response.  If the response does not have any content
1169 or if a data callback is provided to consume the response body,
1170 this will be the empty string
1171
1172 =item *
1173
1174 C<headers>
1175
1176 A hashref of header fields.  All header field names will be normalized
1177 to be lower case. If a header is repeated, the value will be an arrayref;
1178 it will otherwise be a scalar string containing the value
1179
1180 =back
1181
1182 On an exception during the execution of the request, the C<status> field will
1183 contain 599, and the C<content> field will contain the text of the exception.
1184
1185 =head2 www_form_urlencode
1186
1187     $params = $http->www_form_urlencode( $data );
1188     $response = $http->get("http://example.com/query?$params");
1189
1190 This method converts the key/value pairs from a data hash or array reference
1191 into a C<x-www-form-urlencoded> string.  The keys and values from the data
1192 reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
1193 array reference, the key will be repeated with each of the values of the array
1194 reference.  The key/value pairs in the resulting string will be sorted by key
1195 and value.
1196
1197 =for Pod::Coverage agent
1198 default_headers
1199 local_address
1200 max_redirect
1201 max_size
1202 proxy
1203 timeout
1204 verify_SSL
1205 SSL_options
1206
1207 =head1 SSL SUPPORT
1208
1209 Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
1210 greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be
1211 thrown if a new enough versions of these modules not installed or if the SSL
1212 encryption fails. There is no support for C<https> connections via proxy (i.e.
1213 RFC 2817).
1214
1215 SSL provides two distinct capabilities:
1216
1217 =over 4
1218
1219 =item *
1220
1221 Encrypted communication channel
1222
1223 =item *
1224
1225 Verification of server identity
1226
1227 =back
1228
1229 B<By default, HTTP::Tiny does not verify server identity>.
1230
1231 Server identity verification is controversial and potentially tricky because it
1232 depends on a (usually paid) third-party Certificate Authority (CA) trust model
1233 to validate a certificate as legitimate.  This discriminates against servers
1234 with self-signed certificates or certificates signed by free, community-driven
1235 CA's such as L<CAcert.org|http://cacert.org>.
1236
1237 By default, HTTP::Tiny does not make any assumptions about your trust model,
1238 threat level or risk tolerance.  It just aims to give you an encrypted channel
1239 when you need one.
1240
1241 Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify
1242 that an SSL connection has a valid SSL certificate corresponding to the host
1243 name of the connection and that the SSL certificate has been verified by a CA.
1244 Assuming you trust the CA, this will protect against a L<man-in-the-middle
1245 attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>.  If you are
1246 concerned about security, you should enable this option.
1247
1248 Certificate verification requires a file containing trusted CA certificates.
1249 If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
1250 included with it as a source of trusted CA's.  (This means you trust Mozilla,
1251 the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
1252 toolchain used to install it, and your operating system security, right?)
1253
1254 If that module is not available, then HTTP::Tiny will search several
1255 system-specific default locations for a CA certificate file:
1256
1257 =over 4
1258
1259 =item *
1260
1261 /etc/ssl/certs/ca-certificates.crt
1262
1263 =item *
1264
1265 /etc/pki/tls/certs/ca-bundle.crt
1266
1267 =item *
1268
1269 /etc/ssl/ca-bundle.pem
1270
1271 =back
1272
1273 An exception will be raised if C<verify_SSL> is true and no CA certificate file
1274 is available.
1275
1276 If you desire complete control over SSL connections, the C<SSL_options> attribute
1277 lets you provide a hash reference that will be passed through to
1278 C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
1279 example, to provide your own trusted CA file:
1280
1281     SSL_options => {
1282         SSL_ca_file => $file_path,
1283     }
1284
1285 The C<SSL_options> attribute could also be used for such things as providing a
1286 client certificate for authentication to a server or controlling the choice of
1287 cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for
1288 details.
1289
1290 =head1 LIMITATIONS
1291
1292 HTTP::Tiny is I<conditionally compliant> with the
1293 L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
1294 It attempts to meet all "MUST" requirements of the specification, but does not
1295 implement all "SHOULD" requirements.
1296
1297 Some particular limitations of note include:
1298
1299 =over
1300
1301 =item *
1302
1303 HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
1304 that user-defined headers and content are compliant with the HTTP/1.1
1305 specification.
1306
1307 =item *
1308
1309 Users must ensure that URLs are properly escaped for unsafe characters and that
1310 international domain names are properly encoded to ASCII. See L<URI::Escape>,
1311 L<URI::_punycode> and L<Net::IDN::Encode>.
1312
1313 =item *
1314
1315 Redirection is very strict against the specification.  Redirection is only
1316 automatic for response codes 301, 302 and 307 if the request method is 'GET' or
1317 'HEAD'.  Response code 303 is always converted into a 'GET' redirection, as
1318 mandated by the specification.  There is no automatic support for status 305
1319 ("Use proxy") redirections.
1320
1321 =item *
1322
1323 Persistent connections are not supported.  The C<Connection> header will
1324 always be set to C<close>.
1325
1326 =item *
1327
1328 Cookies are not directly supported.  Users that set a C<Cookie> header
1329 should also set C<max_redirect> to zero to ensure cookies are not
1330 inappropriately re-transmitted.
1331
1332 =item *
1333
1334 Only the C<http_proxy> environment variable is supported in the format
1335 C<http://HOST:PORT/>.  If a C<proxy> argument is passed to C<new> (including
1336 undef), then the C<http_proxy> environment variable is ignored.
1337
1338 =item *
1339
1340 There is no provision for delaying a request body using an C<Expect> header.
1341 Unexpected C<1XX> responses are silently ignored as per the specification.
1342
1343 =item *
1344
1345 Only 'chunked' C<Transfer-Encoding> is supported.
1346
1347 =item *
1348
1349 There is no support for a Request-URI of '*' for the 'OPTIONS' request.
1350
1351 =item *
1352
1353 There is no support for IPv6 of any kind.
1354
1355 =back
1356
1357 =head1 SEE ALSO
1358
1359 =over 4
1360
1361 =item *
1362
1363 L<LWP::UserAgent>
1364
1365 =item *
1366
1367 L<IO::Socket::SSL>
1368
1369 =item *
1370
1371 L<Mozilla::CA>
1372
1373 =item *
1374
1375 L<Net::SSLeay>
1376
1377 =back
1378
1379 =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
1380
1381 =head1 SUPPORT
1382
1383 =head2 Bugs / Feature Requests
1384
1385 Please report any bugs or feature requests through the issue tracker
1386 at L<https://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny>.
1387 You will be notified automatically of any progress on your issue.
1388
1389 =head2 Source Code
1390
1391 This is open source software.  The code repository is available for
1392 public review and contribution under the terms of the license.
1393
1394 L<https://github.com/dagolden/http-tiny>
1395
1396   git clone git://github.com/dagolden/http-tiny.git
1397
1398 =head1 AUTHORS
1399
1400 =over 4
1401
1402 =item *
1403
1404 Christian Hansen <chansen@cpan.org>
1405
1406 =item *
1407
1408 David Golden <dagolden@cpan.org>
1409
1410 =item *
1411
1412 Mike Doherty <doherty@cpan.org>
1413
1414 =back
1415
1416 =head1 COPYRIGHT AND LICENSE
1417
1418 This software is copyright (c) 2012 by Christian Hansen.
1419
1420 This is free software; you can redistribute it and/or modify it under
1421 the same terms as the Perl 5 programming language system itself.
1422
1423 =cut