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.05';

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 lines, then their contents will be
joined together with C<\x00>.

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];
}

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 ($scheme, $authority, $upath, $query, $fragment) =
      $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;

   $scheme = lc $scheme;

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

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

   $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\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) {
         next unless $chost eq substr $uhost, -length $chost;
         next unless $chost =~ /^\./;
 
         while (my ($cpath, $v) = each %$v) {
            next unless $cpath eq substr $upath, 0, length $cpath;
 
            while (my ($k, $v) = each %$v) {
               next if $scheme ne "https" && exists $v->{secure};
               push @cookie, "$k=$v->{value}";
            }
         }
      }
 
      $hdr{cookie} = join "; ", @cookie
         if @cookie;
   }

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

   if ($proxy) {
      ($rhost, $rport, $scheme) = @$proxy;
      $rpath = $url;
   } else {
      ($rhost, $rport, $rpath) = ($uhost, $uport, $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 });

         delete $state{connect_guard}; # reduce memory usage, save a tree

         # get handle
         $state{handle} = new AnyEvent::Handle
            fh => $state{fh},
            ($scheme eq "https" ? (tls => "connect") : ());

         # limit the number of persistent connections
         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";
            delete $hdr{connection}; # keep-alive not yet supported
         } else {
            delete $hdr{connection};
         }

         # (re-)configure handle
         $state{handle}->timeout ($timeout);
         $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 });
         });

         # send request
         $state{handle}->push_write (
            "$method $rpath HTTP/1.0\015\012"
            . (join "", map "$_: $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/\015?\012/, 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 => "\x00$1",
               Status      => "\x00$2",
               Reason      => "\x00$3",
               URL         => "\x00$url"
            );

            # headers, could be optimized a bit
            $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
               for ("$_[1]\012") {
                  # we support spaces in field names, as lotus domino
                  # creates them.
                  $hdr{lc $1} .= "\x00$2"
                     while /\G
                           ([^:\000-\037]+):
                           [\011\040]*
                           ((?: [^\015\012]+ | \015?\012[\011\040] )*)
                           \015?\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 = ();

                  # set-cookie processing
                  if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
                     for (split /\x00/, $hdr{"set-cookie"}) {
                        my ($cookie, @arg) = split /;\s*/;
                        my ($name, $value) = split /=/, $cookie, 2;
                        my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
    
                        my $cdom  = (delete $kv{domain}) || $uhost;
                        my $cpath = (delete $kv{path})   || "/";
    
                        $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);
    
                        # store it
                        $arg{cookie_jar}{version} = 1;
                        $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
                     }
                  }

                  # 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 = "$scheme://$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 unlear 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 { });
                  }
               }
            });
         });
      }, 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.29
Committed:	Wed Oct 22 23:28:11 2008 UTC (15 years, 6 months ago) by root
Branch:	MAIN
Changes since 1.28:	+20 -4 lines
Log Message:	* empty log message *
#	Content
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	http_get "http://www.nethype.de/", sub { print $_[1] };
10
11	# ... do something else here
12
13	=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	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	=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	our $VERSION = '1.05';
54
55	our @EXPORT = qw(http_get http_post http_head http_request);
56
57	our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58	our $MAX_RECURSE = 10;
59	our $MAX_PERSISTENT = 8;
60	our $PERSISTENT_TIMEOUT = 2;
61	our $TIMEOUT = 300;
62
63	# changing these is evil
64	our $MAX_PERSISTENT_PER_HOST = 2;
65	our $MAX_PER_HOST = 4;
66
67	our $PROXY;
68	our $ACTIVE = 0;
69
70	my %KA_COUNT; # number of open keep-alive connections per host
71	my %CO_SLOT; # number of open connections, and wait queue, per host
72
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	additional parameters and the return value.
77
78	=item http_head $url, key => value..., $cb->($data, $headers)
79
80	Executes an HTTP-HEAD request. See the http_request function for details
81	on additional parameters and the return value.
82
83	=item http_post $url, $body, key => value..., $cb->($data, $headers)
84
85	Executes an HTTP-POST request with a request body of C<$body>. See the
86	http_request function for details on additional parameters and the return
87	value.
88
89	=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	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	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	All the headers in that hash are lowercased. In addition to the response
104	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	If the server sends a header multiple lines, then their contents will be
110	joined together with C<\x00>.
111
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	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	Additional parameters are key-value pairs, and are fully optional. They
129	include:
130
131	=over 4
132
133	=item recurse => $count (default: $MAX_RECURSE)
134
135	Whether to recurse requests or not, e.g. on redirects, authentication
136	retries and so on, and how often to do so.
137
138	=item headers => hashref
139
140	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
144	=item timeout => $seconds
145
146	The time-out to use for various stages - each connect attempt will reset
147	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
157	=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	=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	=back
179
180	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
200	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	=cut
211
212	sub _slot_schedule;
213	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	# somebody wants that slot
219	++$CO_SLOT{$host}[0];
220	++$ACTIVE;
221
222	$cb->(AnyEvent::Util::guard {
223	--$ACTIVE;
224	--$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	sub http_request($$@) {
243	my $cb = pop;
244	my ($method, $url, %arg) = @_;
245
246	my %hdr;
247
248	$method = uc $method;
249
250	if (my $hdr = $arg{headers}) {
251	while (my ($k, $v) = each %$hdr) {
252	$hdr{lc $k} = $v;
253	}
254	}
255
256	my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
257
258	return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url })
259	if $recurse < 0;
260
261	my $proxy = $arg{proxy} \|\| $PROXY;
262	my $timeout = $arg{timeout} \|\| $TIMEOUT;
263
264	$hdr{"user-agent"} \|\|= $USERAGENT;
265
266	my ($scheme, $authority, $upath, $query, $fragment) =
267	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;
268
269	$scheme = lc $scheme;
270
271	my $uport = $scheme eq "http" ? 80
272	: $scheme eq "https" ? 443
273	: return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported", URL => $url });
274
275	$hdr{referer} \|\|= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic
276
277	$authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
278	or return $cb->(undef, { Status => 599, Reason => "unparsable URL", URL => $url });
279
280	my $uhost = $1;
281	$uport = $2 if defined $2;
282
283	$uhost =~ s/^\[(.*)\]$/$1/;
284	$upath .= "?$query" if length $query;
285
286	$upath =~ s%^/?%/%;
287
288	# cookie processing
289	if (my $jar = $arg{cookie_jar}) {
290	%$jar = () if $jar->{version} < 1;
291
292	my @cookie;
293
294	while (my ($chost, $v) = each %$jar) {
295	next unless $chost eq substr $uhost, -length $chost;
296	next unless $chost =~ /^\./;
297
298	while (my ($cpath, $v) = each %$v) {
299	next unless $cpath eq substr $upath, 0, length $cpath;
300
301	while (my ($k, $v) = each %$v) {
302	next if $scheme ne "https" && exists $v->{secure};
303	push @cookie, "$k=$v->{value}";
304	}
305	}
306	}
307
308	$hdr{cookie} = join "; ", @cookie
309	if @cookie;
310	}
311
312	my ($rhost, $rport, $rpath); # request host, port, path
313
314	if ($proxy) {
315	($rhost, $rport, $scheme) = @$proxy;
316	$rpath = $url;
317	} else {
318	($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
319	$hdr{host} = $uhost;
320	}
321
322	$hdr{"content-length"} = length $arg{body};
323
324	my %state = (connect_guard => 1);
325
326	_get_slot $uhost, sub {
327	$state{slot_guard} = shift;
328
329	return unless $state{connect_guard};
330
331	$state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
332	$state{fh} = shift
333	or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url });
334
335	delete $state{connect_guard}; # reduce memory usage, save a tree
336
337	# get handle
338	$state{handle} = new AnyEvent::Handle
339	fh => $state{fh},
340	($scheme eq "https" ? (tls => "connect") : ());
341
342	# limit the number of persistent connections
343	if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
344	++$KA_COUNT{$_[1]};
345	$state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
346	$hdr{connection} = "keep-alive";
347	delete $hdr{connection}; # keep-alive not yet supported
348	} else {
349	delete $hdr{connection};
350	}
351
352	# (re-)configure handle
353	$state{handle}->timeout ($timeout);
354	$state{handle}->on_error (sub {
355	my $errno = "$!";
356	%state = ();
357	$cb->(undef, { Status => 599, Reason => $errno, URL => $url });
358	});
359	$state{handle}->on_eof (sub {
360	%state = ();
361	$cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url });
362	});
363
364	# send request
365	$state{handle}->push_write (
366	"$method $rpath HTTP/1.0\015\012"
367	. (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
368	. "\015\012"
369	. (delete $arg{body})
370	);
371
372	%hdr = (); # reduce memory usage, save a kitten
373
374	# status line
375	$state{handle}->push_read (line => qr/\015?\012/, sub {
376	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
377	or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
378
379	my %hdr = ( # response headers
380	HTTPVersion => "\x00$1",
381	Status => "\x00$2",
382	Reason => "\x00$3",
383	URL => "\x00$url"
384	);
385
386	# headers, could be optimized a bit
387	$state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
388	for ("$_[1]\012") {
389	# we support spaces in field names, as lotus domino
390	# creates them.
391	$hdr{lc $1} .= "\x00$2"
392	while /\G
393	([^:\000-\037]+):
394	[\011\040]*
395	((?: [^\015\012]+ \| \015?\012[\011\040] )*)
396	\015?\012
397	/gxc;
398
399	/\G$/
400	or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url }));
401	}
402
403	substr $_, 0, 1, ""
404	for values %hdr;
405
406	my $finish = sub {
407	%state = ();
408
409	# set-cookie processing
410	if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
411	for (split /\x00/, $hdr{"set-cookie"}) {
412	my ($cookie, @arg) = split /;\s*/;
413	my ($name, $value) = split /=/, $cookie, 2;
414	my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
415
416	my $cdom = (delete $kv{domain}) \|\| $uhost;
417	my $cpath = (delete $kv{path}) \|\| "/";
418
419	$cdom =~ s/^\.?/./; # make sure it starts with a "."
420
421	next if $cdom =~ /\.$/;
422
423	# this is not rfc-like and not netscape-like. go figure.
424	my $ndots = $cdom =~ y/.//;
425	next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
426
427	# store it
428	$arg{cookie_jar}{version} = 1;
429	$arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
430	}
431	}
432
433	# microsoft and other shitheads don't give a shit for following standards,
434	# try to support some common forms of broken Location headers.
435	if ($_[1]{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
436	$_[1]{location} =~ s/^\.\/+//;
437
438	my $url = "$scheme://$uhost:$uport";
439
440	unless ($_[1]{location} =~ s/^\///) {
441	$url .= $upath;
442	$url =~ s/\/[^\/]*$//;
443	}
444
445	$_[1]{location} = "$url/$_[1]{location}";
446	}
447
448	if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
449	# apparently, mozilla et al. just change POST to GET here
450	# more research is needed before we do the same
451	http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
452	} elsif ($_[1]{Status} == 303 && $recurse) {
453	# even http/1.1 is unlear on how to mutate the method
454	$method = "GET" unless $method eq "HEAD";
455	http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
456	} elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET\|HEAD)$/) {
457	http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
458	} else {
459	$cb->($_[0], $_[1]);
460	}
461	};
462
463	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {
464	$finish->(undef, \%hdr);
465	} else {
466	if (exists $hdr{"content-length"}) {
467	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
468	# could cache persistent connection now
469	if ($hdr{connection} =~ /\bkeep-alive\b/i) {
470	# but we don't, due to misdesigns, this is annoyingly complex
471	};
472
473	$finish->($_[1], \%hdr);
474	});
475	} else {
476	# too bad, need to read until we get an error or EOF,
477	# no way to detect winged data.
478	$_[0]->on_error (sub {
479	$finish->($_[0]{rbuf}, \%hdr);
480	});
481	$_[0]->on_eof (undef);
482	$_[0]->on_read (sub { });
483	}
484	}
485	});
486	});
487	}, sub {
488	$timeout
489	};
490	};
491
492	defined wantarray && AnyEvent::Util::guard { %state = () }
493	}
494
495	sub http_get($@) {
496	unshift @_, "GET";
497	&http_request
498	}
499
500	sub http_head($@) {
501	unshift @_, "HEAD";
502	&http_request
503	}
504
505	sub http_post($$@) {
506	my $url = shift;
507	unshift @_, "POST", $url, "body";
508	&http_request
509	}
510
511	=back
512
513	=head2 GLOBAL FUNCTIONS AND VARIABLES
514
515	=over 4
516
517	=item AnyEvent::HTTP::set_proxy "proxy-url"
518
519	Sets the default proxy server to use. The proxy-url must begin with a
520	string of the form C<http://host:port> (optionally C<https:...>).
521
522	=item $AnyEvent::HTTP::MAX_RECURSE
523
524	The default value for the C<recurse> request parameter (default: C<10>).
525
526	=item $AnyEvent::HTTP::USERAGENT
527
528	The default value for the C<User-Agent> header (the default is
529	C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
530
531	=item $AnyEvent::HTTP::MAX_PERSISTENT
532
533	The maximum number of persistent connections to keep open (default: 8).
534
535	Not implemented currently.
536
537	=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
538
539	The maximum time to cache a persistent connection, in seconds (default: 2).
540
541	Not implemented currently.
542
543	=item $AnyEvent::HTTP::ACTIVE
544
545	The number of active connections. This is not the number of currently
546	running requests, but the number of currently open and non-idle TCP
547	connections. This number of can be useful for load-leveling.
548
549	=back
550
551	=cut
552
553	sub set_proxy($) {
554	$PROXY = [$2, $3 \|\| 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix;
555	}
556
557	# initialise proxy from environment
558	set_proxy $ENV{http_proxy};
559
560	=head1 SEE ALSO
561
562	L<AnyEvent>.
563
564	=head1 AUTHOR
565
566	Marc Lehmann <schmorp@schmorp.de>
567	http://home.schmorp.de/
568
569	=cut
570
571	1
572