AnyEvent-HTTP/HTTP.pm

=head1 NAME

AnyEvent::HTTP - simple but non-blocking HTTP/HTTPS client

=head1 SYNOPSIS

   use AnyEvent::HTTP;

   http_get "http://www.nethype.de/", sub { print $_[1] };

   # ... do something else here

=head1 DESCRIPTION

This module is an L<AnyEvent> user, you need to make sure that you use and
run a supported event loop.

This module implements a simple, stateless and non-blocking HTTP
client. It supports GET, POST and other request methods, cookies and more,
all on a very low level. It can follow redirects supports proxies and
automatically limits the number of connections to the values specified in
the RFC.

It should generally be a "good client" that is enough for most HTTP
tasks. Simple tasks should be simple, but complex tasks should still be
possible as the user retains control over request and response headers.

The caller is responsible for authentication management, cookies (if
the simplistic implementation in this module doesn't suffice), referer
and other high-level protocol details for which this module offers only
limited support.

=head2 METHODS

=over 4

=cut

package AnyEvent::HTTP;

use strict;
no warnings;

use Carp;

use AnyEvent 4.452 ();
use AnyEvent::Util ();
use AnyEvent::Socket ();
use AnyEvent::Handle ();

use base Exporter::;

our $VERSION = '1.12';

our @EXPORT = qw(http_get http_post http_head http_request);

our $USERAGENT          = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
our $MAX_RECURSE        =  10;
our $MAX_PERSISTENT     =   8;
our $PERSISTENT_TIMEOUT =   2;
our $TIMEOUT            = 300;

# changing these is evil
our $MAX_PERSISTENT_PER_HOST = 2;
our $MAX_PER_HOST       = 4;

our $PROXY;
our $ACTIVE = 0;

my %KA_COUNT; # number of open keep-alive connections per host
my %CO_SLOT;  # number of open connections, and wait queue, per host

=item http_get $url, key => value..., $cb->($data, $headers)

Executes an HTTP-GET request. See the http_request function for details on
additional parameters and the return value.

=item http_head $url, key => value..., $cb->($data, $headers)

Executes an HTTP-HEAD request. See the http_request function for details
on additional parameters and the return value.

=item http_post $url, $body, key => value..., $cb->($data, $headers)

Executes an HTTP-POST request with a request body of C<$body>. See the
http_request function for details on additional parameters and the return
value.

=item http_request $method => $url, key => value..., $cb->($data, $headers)

Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
must be an absolute http or https URL.

When called in void context, nothing is returned. In other contexts,
C<http_request> returns a "cancellation guard" - you have to keep the
object at least alive until the callback get called. If the object gets
destroyed before the callbakc is called, the request will be cancelled.

The callback will be called with the response data as first argument
(or C<undef> if it wasn't available due to errors), and a hash-ref with
response headers as second argument.

All the headers in that hash are lowercased. In addition to the response
headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
contain the three parts of the HTTP Status-Line of the same name. The
pseudo-header C<URL> contains the original URL (which can differ from the
requested URL when following redirects).

If the server sends a header multiple times, then their contents will be
joined together with a comma (C<,>), as per the HTTP spec.

If an internal error occurs, such as not being able to resolve a hostname,
then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>
and the C<Reason> pseudo-header will contain an error message.

A typical callback might look like this:

   sub {
      my ($body, $hdr) = @_;

      if ($hdr->{Status} =~ /^2/) {
         ... everything should be ok
      } else {
         print "error, $hdr->{Status} $hdr->{Reason}\n";
      }
   }

Additional parameters are key-value pairs, and are fully optional. They
include:

=over 4

=item recurse => $count (default: $MAX_RECURSE)

Whether to recurse requests or not, e.g. on redirects, authentication
retries and so on, and how often to do so.

=item headers => hashref

The request headers to use. Currently, C<http_request> may provide its
own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
and will provide defaults for C<User-Agent:> and C<Referer:>.

=item timeout => $seconds

The time-out to use for various stages - each connect attempt will reset
the timeout, as will read or write activity. Default timeout is 5 minutes.

=item proxy => [$host, $port[, $scheme]] or undef

Use the given http proxy for all requests. If not specified, then the
default proxy (as specified by C<$ENV{http_proxy}>) is used.

C<$scheme> must be either missing or C<http> for HTTP, or C<https> for
HTTPS.

=item body => $string

The request body, usually empty. Will be-sent as-is (future versions of
this module might offer more options).

=item cookie_jar => $hash_ref

Passing this parameter enables (simplified) cookie-processing, loosely
based on the original netscape specification.

The C<$hash_ref> must be an (initially empty) hash reference which will
get updated automatically. It is possible to save the cookie_jar to
persistent storage with something like JSON or Storable, but this is not
recommended, as expiry times are currently being ignored.

Note that this cookie implementation is not of very high quality, nor
meant to be complete. If you want complete cookie management you have to
do that on your own. C<cookie_jar> is meant as a quick fix to get some
cookie-using sites working. Cookies are a privacy disaster, do not use
them unless required to.

=item tls_ctx => $scheme | $tls_ctx

Specifies the AnyEvent::TLS context to be used for https connections. This
parameter follows the same rules as the C<tls_ctx> parameter to
L<AnyEvent::Handle>, but additionally, the two strings C<low> or
C<high> can be specified, which give you a predefined low-security (no
verification, highest compatibility) and high-security (CA and common-name
verification) TLS context.

The default for this option is C<low>, which could be interpreted as "give
me the page, no matter what".

=back

Example: make a simple HTTP GET request for http://www.nethype.de/

   http_request GET => "http://www.nethype.de/", sub {
      my ($body, $hdr) = @_;
      print "$body\n";
   };

Example: make a HTTP HEAD request on https://www.google.com/, use a
timeout of 30 seconds.

   http_request
      GET     => "https://www.google.com",
      timeout => 30,
      sub {
         my ($body, $hdr) = @_;
         use Data::Dumper;
         print Dumper $hdr;
      }
   ;

Example: make another simple HTTP GET request, but immediately try to
cancel it.

   my $request = http_request GET => "http://www.nethype.de/", sub {
      my ($body, $hdr) = @_;
      print "$body\n";
   };

   undef $request;

=cut

sub _slot_schedule;
sub _slot_schedule($) {
   my $host = shift;

   while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
      if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
         # somebody wants that slot
         ++$CO_SLOT{$host}[0];
         ++$ACTIVE;

         $cb->(AnyEvent::Util::guard {
            --$ACTIVE;
            --$CO_SLOT{$host}[0];
            _slot_schedule $host;
         });
      } else {
         # nobody wants the slot, maybe we can forget about it
         delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
         last;
      }
   }
}

# wait for a free slot on host, call callback
sub _get_slot($$) {
   push @{ $CO_SLOT{$_[0]}[1] }, $_[1];

   _slot_schedule $_[0];
}

our $qr_nl   = qr<\015?\012>;
our $qr_nlnl = qr<\015?\012\015?\012>;

our $TLS_CTX_LOW  = { cache => 1, dh => undef, sslv2 => 1 };
our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_cn => "https", dh => "skip4096" };

sub http_request($$@) {
   my $cb = pop;
   my ($method, $url, %arg) = @_;

   my %hdr;

   $arg{tls_ctx} = $TLS_CTX_LOW  if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
   $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";

   $method = uc $method;

   if (my $hdr = $arg{headers}) {
      while (my ($k, $v) = each %$hdr) {
         $hdr{lc $k} = $v;
      }
   }

   my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;

   return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url })
      if $recurse < 0;

   my $proxy   = $arg{proxy}   || $PROXY;
   my $timeout = $arg{timeout} || $TIMEOUT;

   $hdr{"user-agent"} ||= $USERAGENT;

   my ($uscheme, $uauthority, $upath, $query, $fragment) =
      $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;

   $uscheme = lc $uscheme;

   my $uport = $uscheme eq "http"  ?  80
             : $uscheme eq "https" ? 443
             : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported (not '$uscheme')", URL => $url });

   $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic

   $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
      or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });

   my $uhost = $1;
   $uport = $2 if defined $2;

   $uhost =~ s/^\[(.*)\]$/$1/;
   $upath .= "?$query" if length $query;

   $upath =~ s%^/?%/%;

   # cookie processing
   if (my $jar = $arg{cookie_jar}) {
      %$jar = () if $jar->{version} != 1;
 
      my @cookie;
 
      while (my ($chost, $v) = each %$jar) {
         if ($chost =~ /^\./) {
            next unless $chost eq substr $uhost, -length $chost;
         } elsif ($chost =~ /\./) {
            next unless $chost eq $uhost;
         } else {
            next;
         }
 
         while (my ($cpath, $v) = each %$v) {
            next unless $cpath eq substr $upath, 0, length $cpath;
 
            while (my ($k, $v) = each %$v) {
               next if $uscheme ne "https" && exists $v->{secure};
               my $value = $v->{value};
               $value =~ s/([\\"])/\\$1/g;
               push @cookie, "$k=\"$value\"";
            }
         }
      }
 
      $hdr{cookie} = join "; ", @cookie
         if @cookie;
   }

   my ($rhost, $rport, $rscheme, $rpath); # request host, port, path

   if ($proxy) {
      ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);

      # don't support https requests over https-proxy transport,
      # can't be done with tls as spec'ed, unless you double-encrypt.
      $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
   } else {
      ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
   }

   $hdr{host} = $uhost;
   $hdr{"content-length"} = length $arg{body};

   my %state = (connect_guard => 1);

   _get_slot $uhost, sub {
      $state{slot_guard} = shift;

      return unless $state{connect_guard};

      $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
         $state{fh} = shift
            or return (%state = (), $cb->(undef, { Status => 599, Reason => "$!", URL => $url }));
         pop; # free memory, save a tree

         return unless delete $state{connect_guard};

         # get handle
         $state{handle} = new AnyEvent::Handle
            fh       => $state{fh},
            timeout  => $timeout,
            peername => $rhost,
            tls_ctx  => $arg{tls_ctx};

         # limit the number of persistent connections
         # keepalive not yet supported
         if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
            ++$KA_COUNT{$_[1]};
            $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
               --$KA_COUNT{$_[1]}
            };
            $hdr{connection} = "keep-alive";
         } else {
            delete $hdr{connection};
         }

         # (re-)configure handle
         $state{handle}->on_error (sub {
            %state = ();
            $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
         });
         $state{handle}->on_eof (sub {
            %state = ();
            $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
         });

         $state{handle}->starttls ("connect") if $rscheme eq "https";

         # handle actual, non-tunneled, request
         my $handle_actual_request = sub {
            $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};

            # send request
            $state{handle}->push_write (
               "$method $rpath HTTP/1.0\015\012"
               . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
               . "\015\012"
               . (delete $arg{body})
            );

            %hdr = (); # reduce memory usage, save a kitten

            # status line
            $state{handle}->push_read (line => $qr_nl, sub {
               $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
                  or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));

               my %hdr = ( # response headers
                  HTTPVersion => ",$1",
                  Status      => ",$2",
                  Reason      => ",$3",
                  URL         => ",$url"
               );

               # headers, could be optimized a bit
               $state{handle}->unshift_read (line => $qr_nlnl, sub {
                  for ("$_[1]\012") {
                     y/\015//d; # weed out any \015, as they show up in the weirdest of places.

                     # things seen, not parsed:
                     # p3pP="NON CUR OTPi OUR NOR UNI"

                     $hdr{lc $1} .= ",$2"
                        while /\G
                              ([^:\000-\037]+):
                              [\011\040]*
                              ((?: [^\012]+ | \012[\011\040] )*)
                              \012
                           /gxc;

                     /\G$/
                       or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url }));
                  }

                  substr $_, 0, 1, ""
                     for values %hdr;

                  my $finish = sub {
                     $state{handle}->destroy;
                     %state = ();

                     # set-cookie processing
                     if ($arg{cookie_jar}) {
                        for ($hdr{"set-cookie"}) {
                           # parse NAME=VALUE
                           my @kv;

                           while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
                              my $name = $1;
                              my $value = $3;

                              unless ($value) {
                                 $value = $2;
                                 $value =~ s/\\(.)/$1/gs;
                              }

                              push @kv, $name => $value;

                              last unless /\G\s*;/gc;
                           }

                           last unless @kv;

                           my $name = shift @kv;
                           my %kv = (value => shift @kv, @kv);

                           my $cdom;
                           my $cpath = (delete $kv{path}) || "/";

                           if (exists $kv{domain}) {
                              $cdom = delete $kv{domain};
       
                              $cdom =~ s/^\.?/./; # make sure it starts with a "."

                              next if $cdom =~ /\.$/;
          
                              # this is not rfc-like and not netscape-like. go figure.
                              my $ndots = $cdom =~ y/.//;
                              next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
                           } else {
                              $cdom = $uhost;
                           }
       
                           # store it
                           $arg{cookie_jar}{version} = 1;
                           $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;

                           redo if /\G\s*,/gc;
                        }
                     }

                     # microsoft and other shitheads don't give a shit for following standards,
                     # try to support some common forms of broken Location headers.
                     if ($_[1]{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
                        $_[1]{location} =~ s/^\.\/+//;

                        my $url = "$rscheme://$uhost:$uport";

                        unless ($_[1]{location} =~ s/^\///) {
                           $url .= $upath;
                           $url =~ s/\/[^\/]*$//;
                        }

                        $_[1]{location} = "$url/$_[1]{location}";
                     }

                     if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
                        # apparently, mozilla et al. just change POST to GET here
                        # more research is needed before we do the same
                        http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
                     } elsif ($_[1]{Status} == 303 && $recurse) {
                        # even http/1.1 is unclear on how to mutate the method
                        $method = "GET" unless $method eq "HEAD";
                        http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
                     } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) {
                        http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
                     } else {
                        $cb->($_[0], $_[1]);
                     }
                  };

                  if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
                     $finish->(undef, \%hdr);
                  } else {
                     if (exists $hdr{"content-length"}) {
                        $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
                           # could cache persistent connection now
                           if ($hdr{connection} =~ /\bkeep-alive\b/i) {
                              # but we don't, due to misdesigns, this is annoyingly complex
                           };

                           $finish->($_[1], \%hdr);
                        });
                     } else {
                        # too bad, need to read until we get an error or EOF,
                        # no way to detect winged data.
                        $_[0]->on_error (sub {
                           # delete ought to be more efficient, as we would have to make
                           # a copy otherwise as $_[0] gets destroyed.
                           $finish->(delete $_[0]{rbuf}, \%hdr);
                        });
                        $_[0]->on_eof (undef);
                        $_[0]->on_read (sub { });
                     }
                  }
               });
            });
         };

         # now handle proxy-CONNECT method
         if ($proxy && $uscheme eq "https") {
            # oh dear, we have to wrap it into a connect request

            # maybe re-use $uauthority with patched port?
            $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
            $state{handle}->push_read (line => $qr_nlnl, sub {
               $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
                  or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url }));

               if ($2 == 200) {
                  $rpath = $upath;
                  &$handle_actual_request;
               } else {
                  %state = ();
                  $cb->(undef, { Status => $2, Reason => $3, URL => $url });
               }
            });
         } else {
            &$handle_actual_request;
         }

      }, sub {
         $timeout
      };
   };

   defined wantarray && AnyEvent::Util::guard { %state = () }
}

sub http_get($@) {
   unshift @_, "GET";
   &http_request
}

sub http_head($@) {
   unshift @_, "HEAD";
   &http_request
}

sub http_post($$@) {
   my $url = shift;
   unshift @_, "POST", $url, "body";
   &http_request
}

=back

=head2 GLOBAL FUNCTIONS AND VARIABLES

=over 4

=item AnyEvent::HTTP::set_proxy "proxy-url"

Sets the default proxy server to use. The proxy-url must begin with a
string of the form C<http://host:port> (optionally C<https:...>).

=item $AnyEvent::HTTP::MAX_RECURSE

The default value for the C<recurse> request parameter (default: C<10>).

=item $AnyEvent::HTTP::USERAGENT

The default value for the C<User-Agent> header (the default is
C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).

=item $AnyEvent::HTTP::MAX_PERSISTENT

The maximum number of persistent connections to keep open (default: 8).

Not implemented currently.

=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT

The maximum time to cache a persistent connection, in seconds (default: 2).

Not implemented currently.

=item $AnyEvent::HTTP::ACTIVE

The number of active connections. This is not the number of currently
running requests, but the number of currently open and non-idle TCP
connections. This number of can be useful for load-leveling.

=back

=cut

sub set_proxy($) {
   $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix;
}

# initialise proxy from environment
set_proxy $ENV{http_proxy};

=head1 SEE ALSO

L<AnyEvent>.

=head1 AUTHOR

   Marc Lehmann <schmorp@schmorp.de>
   http://home.schmorp.de/

With many thanks to Дмитрий Шалашов, who provided countless
testcases and bugreports.

=cut

1

Revision:	1.40
Committed:	Sun Jul 5 01:45:01 2009 UTC (14 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.39:	+39 -20 lines
Log Message:	* empty log message *