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 ();
use AnyEvent::Util ();
use AnyEvent::Socket ();
use AnyEvent::Handle ();

use base Exporter::;

our $VERSION = '1.1';

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

our $USERAGENT          = "Mozilla/5.0 (compatible; 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 expire 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.

=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>;

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

   my %hdr;

   $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 => "recursion limit reached", 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", 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) {
      ($rhost, $rport, $rscheme, $rpath) = (@$proxy, $url);

      # don't support https requests over https-proxy transport,
      # can't be done with tls as spec'ed.
      $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 $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;

         # 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 {
            my $errno = "$!";
            %state = ();
            $cb->(undef, { Status => 599, Reason => $errno, 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.

                     # we support spaces in field names, as lotus domino
                     # creates them (actually spaces around seperators
                     # are strictly allowed in http, they are a security issue).
                     $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 {
                           $finish->($_[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; 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/

=cut

1

Revision:	1.35
Committed:	Thu Oct 30 03:47:01 2008 UTC (15 years, 6 months ago) by root
Branch:	MAIN
CVS Tags:	rel-1_1
Changes since 1.34:	+2 -5 lines
Log Message:	1.1
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			AnyEvent::HTTP - simple but non-blocking HTTP/HTTPS client
4
5			=head1 SYNOPSIS
6
7			use AnyEvent::HTTP;
8
9	root	1.17	http_get "http://www.nethype.de/", sub { print $_[1] };
10
11			# ... do something else here
12
13	root	1.1	=head1 DESCRIPTION
14
15			This module is an L<AnyEvent> user, you need to make sure that you use and
16			run a supported event loop.
17
18	root	1.11	This module implements a simple, stateless and non-blocking HTTP
19			client. It supports GET, POST and other request methods, cookies and more,
20			all on a very low level. It can follow redirects supports proxies and
21			automatically limits the number of connections to the values specified in
22			the RFC.
23
24			It should generally be a "good client" that is enough for most HTTP
25			tasks. Simple tasks should be simple, but complex tasks should still be
26			possible as the user retains control over request and response headers.
27
28			The caller is responsible for authentication management, cookies (if
29			the simplistic implementation in this module doesn't suffice), referer
30			and other high-level protocol details for which this module offers only
31			limited support.
32
33	root	1.1	=head2 METHODS
34
35			=over 4
36
37			=cut
38
39			package AnyEvent::HTTP;
40
41			use strict;
42			no warnings;
43
44			use Carp;
45
46			use AnyEvent ();
47			use AnyEvent::Util ();
48			use AnyEvent::Socket ();
49			use AnyEvent::Handle ();
50
51			use base Exporter::;
52
53	root	1.35	our $VERSION = '1.1';
54	root	1.1
55	root	1.17	our @EXPORT = qw(http_get http_post http_head http_request);
56	root	1.1
57			our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58	root	1.3	our $MAX_RECURSE = 10;
59	root	1.2	our $MAX_PERSISTENT = 8;
60			our $PERSISTENT_TIMEOUT = 2;
61			our $TIMEOUT = 300;
62	root	1.1
63			# changing these is evil
64			our $MAX_PERSISTENT_PER_HOST = 2;
65	root	1.11	our $MAX_PER_HOST = 4;
66	root	1.1
67	root	1.2	our $PROXY;
68	root	1.14	our $ACTIVE = 0;
69	root	1.2
70	root	1.1	my %KA_COUNT; # number of open keep-alive connections per host
71	root	1.11	my %CO_SLOT; # number of open connections, and wait queue, per host
72	root	1.1
73			=item http_get $url, key => value..., $cb->($data, $headers)
74
75			Executes an HTTP-GET request. See the http_request function for details on
76	root	1.29	additional parameters and the return value.
77	root	1.1
78	root	1.5	=item http_head $url, key => value..., $cb->($data, $headers)
79
80	root	1.29	Executes an HTTP-HEAD request. See the http_request function for details
81			on additional parameters and the return value.
82	root	1.5
83			=item http_post $url, $body, key => value..., $cb->($data, $headers)
84	root	1.3
85	root	1.26	Executes an HTTP-POST request with a request body of C<$body>. See the
86	root	1.29	http_request function for details on additional parameters and the return
87			value.
88	root	1.3
89	root	1.1	=item http_request $method => $url, key => value..., $cb->($data, $headers)
90
91			Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
92			must be an absolute http or https URL.
93
94	root	1.29	When called in void context, nothing is returned. In other contexts,
95			C<http_request> returns a "cancellation guard" - you have to keep the
96			object at least alive until the callback get called. If the object gets
97			destroyed before the callbakc is called, the request will be cancelled.
98
99	root	1.2	The callback will be called with the response data as first argument
100			(or C<undef> if it wasn't available due to errors), and a hash-ref with
101			response headers as second argument.
102
103	root	1.7	All the headers in that hash are lowercased. In addition to the response
104	root	1.20	headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
105			contain the three parts of the HTTP Status-Line of the same name. The
106			pseudo-header C<URL> contains the original URL (which can differ from the
107			requested URL when following redirects).
108
109	root	1.32	If the server sends a header multiple times, then their contents will be
110			joined together with a comma (C<,>), as per the HTTP spec.
111	root	1.2
112			If an internal error occurs, such as not being able to resolve a hostname,
113			then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>
114			and the C<Reason> pseudo-header will contain an error message.
115
116	root	1.6	A typical callback might look like this:
117
118			sub {
119			my ($body, $hdr) = @_;
120
121			if ($hdr->{Status} =~ /^2/) {
122			... everything should be ok
123			} else {
124			print "error, $hdr->{Status} $hdr->{Reason}\n";
125			}
126			}
127
128	root	1.1	Additional parameters are key-value pairs, and are fully optional. They
129			include:
130
131			=over 4
132
133	root	1.3	=item recurse => $count (default: $MAX_RECURSE)
134	root	1.1
135			Whether to recurse requests or not, e.g. on redirects, authentication
136	root	1.3	retries and so on, and how often to do so.
137	root	1.1
138			=item headers => hashref
139
140	root	1.12	The request headers to use. Currently, C<http_request> may provide its
141			own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
142			and will provide defaults for C<User-Agent:> and C<Referer:>.
143	root	1.1
144			=item timeout => $seconds
145
146			The time-out to use for various stages - each connect attempt will reset
147	root	1.2	the timeout, as will read or write activity. Default timeout is 5 minutes.
148
149			=item proxy => [$host, $port[, $scheme]] or undef
150
151			Use the given http proxy for all requests. If not specified, then the
152			default proxy (as specified by C<$ENV{http_proxy}>) is used.
153
154			C<$scheme> must be either missing or C<http> for HTTP, or C<https> for
155			HTTPS.
156	root	1.1
157	root	1.3	=item body => $string
158
159			The request body, usually empty. Will be-sent as-is (future versions of
160			this module might offer more options).
161
162	root	1.10	=item cookie_jar => $hash_ref
163
164			Passing this parameter enables (simplified) cookie-processing, loosely
165			based on the original netscape specification.
166
167			The C<$hash_ref> must be an (initially empty) hash reference which will
168			get updated automatically. It is possible to save the cookie_jar to
169			persistent storage with something like JSON or Storable, but this is not
170			recommended, as expire times are currently being ignored.
171
172			Note that this cookie implementation is not of very high quality, nor
173			meant to be complete. If you want complete cookie management you have to
174			do that on your own. C<cookie_jar> is meant as a quick fix to get some
175			cookie-using sites working. Cookies are a privacy disaster, do not use
176			them unless required to.
177
178	root	1.1	=back
179
180	root	1.9	Example: make a simple HTTP GET request for http://www.nethype.de/
181
182			http_request GET => "http://www.nethype.de/", sub {
183			my ($body, $hdr) = @_;
184			print "$body\n";
185			};
186
187			Example: make a HTTP HEAD request on https://www.google.com/, use a
188			timeout of 30 seconds.
189
190			http_request
191			GET => "https://www.google.com",
192			timeout => 30,
193			sub {
194			my ($body, $hdr) = @_;
195			use Data::Dumper;
196			print Dumper $hdr;
197			}
198			;
199	root	1.1
200	root	1.29	Example: make another simple HTTP GET request, but immediately try to
201			cancel it.
202
203			my $request = http_request GET => "http://www.nethype.de/", sub {
204			my ($body, $hdr) = @_;
205			print "$body\n";
206			};
207
208			undef $request;
209
210	root	1.1	=cut
211
212	root	1.12	sub _slot_schedule;
213	root	1.11	sub _slot_schedule($) {
214			my $host = shift;
215
216			while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
217			if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
218	root	1.12	# somebody wants that slot
219	root	1.11	++$CO_SLOT{$host}[0];
220	root	1.14	++$ACTIVE;
221	root	1.11
222			$cb->(AnyEvent::Util::guard {
223	root	1.14	--$ACTIVE;
224	root	1.11	--$CO_SLOT{$host}[0];
225			_slot_schedule $host;
226			});
227			} else {
228			# nobody wants the slot, maybe we can forget about it
229			delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
230			last;
231			}
232			}
233			}
234
235			# wait for a free slot on host, call callback
236			sub _get_slot($$) {
237			push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
238
239			_slot_schedule $_[0];
240			}
241
242	root	1.34	our $qr_nl = qr<\015?\012>;
243			our $qr_nlnl = qr<\015?\012\015?\012>;
244
245	elmex	1.15	sub http_request($$@) {
246	root	1.1	my $cb = pop;
247			my ($method, $url, %arg) = @_;
248
249			my %hdr;
250
251	root	1.3	$method = uc $method;
252
253	root	1.8	if (my $hdr = $arg{headers}) {
254	root	1.1	while (my ($k, $v) = each %$hdr) {
255			$hdr{lc $k} = $v;
256			}
257			}
258
259	root	1.23	my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
260	root	1.8
261	elmex	1.19	return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url })
262	root	1.8	if $recurse < 0;
263
264	root	1.2	my $proxy = $arg{proxy} \|\| $PROXY;
265	root	1.1	my $timeout = $arg{timeout} \|\| $TIMEOUT;
266
267			$hdr{"user-agent"} \|\|= $USERAGENT;
268
269	root	1.31	my ($uscheme, $uauthority, $upath, $query, $fragment) =
270	root	1.10	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;
271	root	1.2
272	root	1.31	$uscheme = lc $uscheme;
273	root	1.1
274	root	1.31	my $uport = $uscheme eq "http" ? 80
275			: $uscheme eq "https" ? 443
276	elmex	1.19	: return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported", URL => $url });
277	root	1.10
278	root	1.31	$hdr{referer} \|\|= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
279	root	1.13
280	root	1.31	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
281	elmex	1.19	or return $cb->(undef, { Status => 599, Reason => "unparsable URL", URL => $url });
282	root	1.10
283			my $uhost = $1;
284			$uport = $2 if defined $2;
285
286			$uhost =~ s/^\[(.*)\]$/$1/;
287			$upath .= "?$query" if length $query;
288
289			$upath =~ s%^/?%/%;
290
291			# cookie processing
292			if (my $jar = $arg{cookie_jar}) {
293	root	1.31	%$jar = () if $jar->{version} != 1;
294	root	1.10
295			my @cookie;
296
297			while (my ($chost, $v) = each %$jar) {
298	root	1.30	if ($chost =~ /^\./) {
299			next unless $chost eq substr $uhost, -length $chost;
300			} elsif ($chost =~ /\./) {
301			next unless $chost eq $uhost;
302			} else {
303			next;
304			}
305	root	1.10
306			while (my ($cpath, $v) = each %$v) {
307			next unless $cpath eq substr $upath, 0, length $cpath;
308
309			while (my ($k, $v) = each %$v) {
310	root	1.31	next if $uscheme ne "https" && exists $v->{secure};
311			my $value = $v->{value};
312			$value =~ s/([\\"])/\\$1/g;
313			push @cookie, "$k=\"$value\"";
314	root	1.10	}
315			}
316			}
317
318			$hdr{cookie} = join "; ", @cookie
319			if @cookie;
320			}
321	root	1.1
322	root	1.31	my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
323	root	1.2
324	root	1.10	if ($proxy) {
325	root	1.31	($rhost, $rport, $rscheme, $rpath) = (@$proxy, $url);
326
327			# don't support https requests over https-proxy transport,
328			# can't be done with tls as spec'ed.
329			$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
330	root	1.10	} else {
331	root	1.31	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
332	root	1.2	}
333
334	root	1.31	$hdr{host} = $uhost;
335	root	1.10	$hdr{"content-length"} = length $arg{body};
336	root	1.1
337	root	1.11	my %state = (connect_guard => 1);
338
339			_get_slot $uhost, sub {
340			$state{slot_guard} = shift;
341	root	1.1
342	root	1.11	return unless $state{connect_guard};
343	root	1.1
344	root	1.11	$state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
345			$state{fh} = shift
346	elmex	1.19	or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url });
347	root	1.34	pop; # free memory, save a tree
348	root	1.11
349	root	1.34	return unless delete $state{connect_guard};
350	root	1.11
351			# get handle
352			$state{handle} = new AnyEvent::Handle
353	root	1.34	fh => $state{fh},
354			timeout => $timeout;
355	root	1.11
356			# limit the number of persistent connections
357	root	1.34	# keepalive not yet supported
358	root	1.11	if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
359			++$KA_COUNT{$_[1]};
360	root	1.34	$state{handle}{ka_count_guard} = AnyEvent::Util::guard {
361			--$KA_COUNT{$_[1]}
362			};
363	root	1.11	$hdr{connection} = "keep-alive";
364			} else {
365			delete $hdr{connection};
366			}
367	root	1.1
368	root	1.11	# (re-)configure handle
369			$state{handle}->on_error (sub {
370	root	1.14	my $errno = "$!";
371	root	1.11	%state = ();
372	elmex	1.19	$cb->(undef, { Status => 599, Reason => $errno, URL => $url });
373	root	1.11	});
374			$state{handle}->on_eof (sub {
375			%state = ();
376	elmex	1.19	$cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url });
377	root	1.11	});
378	root	1.1
379	root	1.31	$state{handle}->starttls ("connect") if $rscheme eq "https";
380
381			# handle actual, non-tunneled, request
382			my $handle_actual_request = sub {
383	root	1.34	$state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
384	root	1.31
385			# send request
386			$state{handle}->push_write (
387			"$method $rpath HTTP/1.0\015\012"
388			. (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
389			. "\015\012"
390			. (delete $arg{body})
391	root	1.11	);
392
393	root	1.31	%hdr = (); # reduce memory usage, save a kitten
394	root	1.10
395	root	1.31	# status line
396	root	1.34	$state{handle}->push_read (line => $qr_nl, sub {
397	root	1.31	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
398			or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
399
400			my %hdr = ( # response headers
401			HTTPVersion => ",$1",
402			Status => ",$2",
403			Reason => ",$3",
404			URL => ",$url"
405			);
406
407			# headers, could be optimized a bit
408	root	1.34	$state{handle}->unshift_read (line => $qr_nlnl, sub {
409	root	1.31	for ("$_[1]\012") {
410			y/\015//d; # weed out any \015, as they show up in the weirdest of places.
411
412			# we support spaces in field names, as lotus domino
413			# creates them (actually spaces around seperators
414			# are strictly allowed in http, they are a security issue).
415			$hdr{lc $1} .= ",$2"
416			while /\G
417			([^:\000-\037]+):
418			[\011\040]*
419			((?: [^\012]+ \| \012[\011\040] )*)
420			\012
421			/gxc;
422
423			/\G$/
424			or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url }));
425			}
426
427			substr $_, 0, 1, ""
428			for values %hdr;
429
430			my $finish = sub {
431	root	1.35	$state{handle}->destroy;
432	root	1.31	%state = ();
433
434			# set-cookie processing
435			if ($arg{cookie_jar}) {
436			for ($hdr{"set-cookie"}) {
437			# parse NAME=VALUE
438			my @kv;
439
440			while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {
441			my $name = $1;
442			my $value = $3;
443
444			unless ($value) {
445			$value = $2;
446			$value =~ s/\\(.)/$1/gs;
447			}
448
449			push @kv, $name => $value;
450
451			last unless /\G\s*;/gc;
452			}
453
454			last unless @kv;
455	root	1.10
456	root	1.31	my $name = shift @kv;
457			my %kv = (value => shift @kv, @kv);
458	root	1.11
459	root	1.31	my $cdom;
460			my $cpath = (delete $kv{path}) \|\| "/";
461	root	1.10
462	root	1.31	if (exists $kv{domain}) {
463			$cdom = delete $kv{domain};
464
465			$cdom =~ s/^\.?/./; # make sure it starts with a "."
466	root	1.11
467	root	1.31	next if $cdom =~ /\.$/;
468
469			# this is not rfc-like and not netscape-like. go figure.
470			my $ndots = $cdom =~ y/.//;
471			next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
472			} else {
473			$cdom = $uhost;
474			}
475	root	1.30
476	root	1.31	# store it
477			$arg{cookie_jar}{version} = 1;
478			$arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
479
480			redo if /\G\s*,/gc;
481	root	1.30	}
482	root	1.11	}
483	root	1.8
484	root	1.31	# microsoft and other shitheads don't give a shit for following standards,
485			# try to support some common forms of broken Location headers.
486			if ($_[1]{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
487			$_[1]{location} =~ s/^\.\/+//;
488
489			my $url = "$rscheme://$uhost:$uport";
490
491			unless ($_[1]{location} =~ s/^\///) {
492			$url .= $upath;
493			$url =~ s/\/[^\/]*$//;
494			}
495
496			$_[1]{location} = "$url/$_[1]{location}";
497	root	1.25	}
498
499	root	1.31	if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
500			# apparently, mozilla et al. just change POST to GET here
501			# more research is needed before we do the same
502			http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
503			} elsif ($_[1]{Status} == 303 && $recurse) {
504			# even http/1.1 is unclear on how to mutate the method
505			$method = "GET" unless $method eq "HEAD";
506			http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
507			} elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET\|HEAD)$/) {
508			http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
509			} else {
510			$cb->($_[0], $_[1]);
511			}
512			};
513	root	1.24
514	root	1.31	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {
515			$finish->(undef, \%hdr);
516	root	1.11	} else {
517	root	1.31	if (exists $hdr{"content-length"}) {
518			$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
519			# could cache persistent connection now
520			if ($hdr{connection} =~ /\bkeep-alive\b/i) {
521			# but we don't, due to misdesigns, this is annoyingly complex
522			};
523
524			$finish->($_[1], \%hdr);
525			});
526			} else {
527			# too bad, need to read until we get an error or EOF,
528			# no way to detect winged data.
529			$_[0]->on_error (sub {
530			$finish->($_[0]{rbuf}, \%hdr);
531			});
532			$_[0]->on_eof (undef);
533			$_[0]->on_read (sub { });
534			}
535	root	1.11	}
536	root	1.31	});
537			});
538			};
539	root	1.3
540	root	1.31	# now handle proxy-CONNECT method
541			if ($proxy && $uscheme eq "https") {
542			# oh dear, we have to wrap it into a connect request
543
544			# maybe re-use $uauthority with patched port?
545			$state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
546	root	1.34	$state{handle}->push_read (line => $qr_nlnl, sub {
547	root	1.31	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
548			or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid proxy connect response ($_[1])", URL => $url }));
549
550			if ($2 == 200) {
551			$rpath = $upath;
552			&$handle_actual_request;
553	root	1.3	} else {
554	root	1.31	%state = ();
555			$cb->(undef, { Status => $2, Reason => $3, URL => $url });
556	root	1.3	}
557	root	1.11	});
558	root	1.31	} else {
559			&$handle_actual_request;
560			}
561
562	root	1.11	}, sub {
563			$timeout
564			};
565	root	1.1	};
566
567			defined wantarray && AnyEvent::Util::guard { %state = () }
568			}
569
570	elmex	1.15	sub http_get($@) {
571	root	1.1	unshift @_, "GET";
572			&http_request
573			}
574
575	elmex	1.15	sub http_head($@) {
576	root	1.4	unshift @_, "HEAD";
577			&http_request
578			}
579
580	elmex	1.15	sub http_post($$@) {
581	root	1.22	my $url = shift;
582			unshift @_, "POST", $url, "body";
583	root	1.3	&http_request
584			}
585
586	root	1.9	=back
587
588	root	1.2	=head2 GLOBAL FUNCTIONS AND VARIABLES
589	root	1.1
590			=over 4
591
592	root	1.2	=item AnyEvent::HTTP::set_proxy "proxy-url"
593
594			Sets the default proxy server to use. The proxy-url must begin with a
595			string of the form C<http://host:port> (optionally C<https:...>).
596
597	root	1.3	=item $AnyEvent::HTTP::MAX_RECURSE
598	root	1.1
599	root	1.3	The default value for the C<recurse> request parameter (default: C<10>).
600	root	1.1
601			=item $AnyEvent::HTTP::USERAGENT
602
603			The default value for the C<User-Agent> header (the default is
604			C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
605
606			=item $AnyEvent::HTTP::MAX_PERSISTENT
607
608			The maximum number of persistent connections to keep open (default: 8).
609
610	root	1.3	Not implemented currently.
611
612	root	1.1	=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
613
614	root	1.2	The maximum time to cache a persistent connection, in seconds (default: 2).
615	root	1.1
616	root	1.3	Not implemented currently.
617
618	root	1.14	=item $AnyEvent::HTTP::ACTIVE
619
620			The number of active connections. This is not the number of currently
621			running requests, but the number of currently open and non-idle TCP
622			connections. This number of can be useful for load-leveling.
623
624	root	1.1	=back
625
626			=cut
627
628	root	1.2	sub set_proxy($) {
629			$PROXY = [$2, $3 \|\| 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix;
630			}
631
632			# initialise proxy from environment
633			set_proxy $ENV{http_proxy};
634
635	root	1.1	=head1 SEE ALSO
636
637			L<AnyEvent>.
638
639			=head1 AUTHOR
640
641	root	1.18	Marc Lehmann <schmorp@schmorp.de>
642			http://home.schmorp.de/
643	root	1.1
644			=cut
645
646			1
647