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) {
         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 $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 (actually spaces around seperators
                  # are strictly allowed in http, they are a security issue).
                  $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 {
                  # TODO: use destroy method, when/if available
                  #$state{handle}->destroy;
                  $state{handle}->on_eof   (undef);
                  $state{handle}->on_error (undef);
                  %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;
                        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;
                     }
                  }

                  # 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 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 { });
                  }
               }
            });
         });
      }, 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.30
Committed:	Thu Oct 23 02:46:20 2008 UTC (15 years, 6 months ago) by root
Branch:	MAIN
Changes since 1.29:	+27 -11 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	if ($chost =~ /^\./) {
296	next unless $chost eq substr $uhost, -length $chost;
297	} elsif ($chost =~ /\./) {
298	next unless $chost eq $uhost;
299	} else {
300	next;
301	}
302
303	while (my ($cpath, $v) = each %$v) {
304	next unless $cpath eq substr $upath, 0, length $cpath;
305
306	while (my ($k, $v) = each %$v) {
307	next if $scheme ne "https" && exists $v->{secure};
308	push @cookie, "$k=$v->{value}";
309	}
310	}
311	}
312
313	$hdr{cookie} = join "; ", @cookie
314	if @cookie;
315	}
316
317	my ($rhost, $rport, $rpath); # request host, port, path
318
319	if ($proxy) {
320	($rhost, $rport, $scheme) = @$proxy;
321	$rpath = $url;
322	} else {
323	($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
324	$hdr{host} = $uhost;
325	}
326
327	$hdr{"content-length"} = length $arg{body};
328
329	my %state = (connect_guard => 1);
330
331	_get_slot $uhost, sub {
332	$state{slot_guard} = shift;
333
334	return unless $state{connect_guard};
335
336	$state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
337	$state{fh} = shift
338	or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url });
339
340	delete $state{connect_guard}; # reduce memory usage, save a tree
341
342	# get handle
343	$state{handle} = new AnyEvent::Handle
344	fh => $state{fh},
345	($scheme eq "https" ? (tls => "connect") : ());
346
347	# limit the number of persistent connections
348	if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
349	++$KA_COUNT{$_[1]};
350	$state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
351	$hdr{connection} = "keep-alive";
352	delete $hdr{connection}; # keep-alive not yet supported
353	} else {
354	delete $hdr{connection};
355	}
356
357	# (re-)configure handle
358	$state{handle}->timeout ($timeout);
359	$state{handle}->on_error (sub {
360	my $errno = "$!";
361	%state = ();
362	$cb->(undef, { Status => 599, Reason => $errno, URL => $url });
363	});
364	$state{handle}->on_eof (sub {
365	%state = ();
366	$cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url });
367	});
368
369	# send request
370	$state{handle}->push_write (
371	"$method $rpath HTTP/1.0\015\012"
372	. (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
373	. "\015\012"
374	. (delete $arg{body})
375	);
376
377	%hdr = (); # reduce memory usage, save a kitten
378
379	# status line
380	$state{handle}->push_read (line => qr/\015?\012/, sub {
381	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
382	or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
383
384	my %hdr = ( # response headers
385	HTTPVersion => "\x00$1",
386	Status => "\x00$2",
387	Reason => "\x00$3",
388	URL => "\x00$url"
389	);
390
391	# headers, could be optimized a bit
392	$state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
393	for ("$_[1]\012") {
394	# we support spaces in field names, as lotus domino
395	# creates them (actually spaces around seperators
396	# are strictly allowed in http, they are a security issue).
397	$hdr{lc $1} .= "\x00$2"
398	while /\G
399	([^:\000-\037]+):
400	[\011\040]*
401	((?: [^\015\012]+ \| \015?\012[\011\040] )*)
402	\015?\012
403	/gxc;
404
405	/\G$/
406	or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url }));
407	}
408
409	substr $_, 0, 1, ""
410	for values %hdr;
411
412	my $finish = sub {
413	# TODO: use destroy method, when/if available
414	#$state{handle}->destroy;
415	$state{handle}->on_eof (undef);
416	$state{handle}->on_error (undef);
417	%state = ();
418
419	# set-cookie processing
420	if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
421	for (split /\x00/, $hdr{"set-cookie"}) {
422	my ($cookie, @arg) = split /;\s*/;
423	my ($name, $value) = split /=/, $cookie, 2;
424	my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
425
426	my $cdom;
427	my $cpath = (delete $kv{path}) \|\| "/";
428
429	if (exists $kv{domain}) {
430	$cdom = delete $kv{domain};
431
432	$cdom =~ s/^\.?/./; # make sure it starts with a "."
433
434	next if $cdom =~ /\.$/;
435
436	# this is not rfc-like and not netscape-like. go figure.
437	my $ndots = $cdom =~ y/.//;
438	next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
439	} else {
440	$cdom = $uhost;
441	}
442
443	# store it
444	$arg{cookie_jar}{version} = 1;
445	$arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
446	}
447	}
448
449	# microsoft and other shitheads don't give a shit for following standards,
450	# try to support some common forms of broken Location headers.
451	if ($_[1]{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
452	$_[1]{location} =~ s/^\.\/+//;
453
454	my $url = "$scheme://$uhost:$uport";
455
456	unless ($_[1]{location} =~ s/^\///) {
457	$url .= $upath;
458	$url =~ s/\/[^\/]*$//;
459	}
460
461	$_[1]{location} = "$url/$_[1]{location}";
462	}
463
464	if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
465	# apparently, mozilla et al. just change POST to GET here
466	# more research is needed before we do the same
467	http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
468	} elsif ($_[1]{Status} == 303 && $recurse) {
469	# even http/1.1 is unclear on how to mutate the method
470	$method = "GET" unless $method eq "HEAD";
471	http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
472	} elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET\|HEAD)$/) {
473	http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
474	} else {
475	$cb->($_[0], $_[1]);
476	}
477	};
478
479	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {
480	$finish->(undef, \%hdr);
481	} else {
482	if (exists $hdr{"content-length"}) {
483	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
484	# could cache persistent connection now
485	if ($hdr{connection} =~ /\bkeep-alive\b/i) {
486	# but we don't, due to misdesigns, this is annoyingly complex
487	};
488
489	$finish->($_[1], \%hdr);
490	});
491	} else {
492	# too bad, need to read until we get an error or EOF,
493	# no way to detect winged data.
494	$_[0]->on_error (sub {
495	$finish->($_[0]{rbuf}, \%hdr);
496	});
497	$_[0]->on_eof (undef);
498	$_[0]->on_read (sub { });
499	}
500	}
501	});
502	});
503	}, sub {
504	$timeout
505	};
506	};
507
508	defined wantarray && AnyEvent::Util::guard { %state = () }
509	}
510
511	sub http_get($@) {
512	unshift @_, "GET";
513	&http_request
514	}
515
516	sub http_head($@) {
517	unshift @_, "HEAD";
518	&http_request
519	}
520
521	sub http_post($$@) {
522	my $url = shift;
523	unshift @_, "POST", $url, "body";
524	&http_request
525	}
526
527	=back
528
529	=head2 GLOBAL FUNCTIONS AND VARIABLES
530
531	=over 4
532
533	=item AnyEvent::HTTP::set_proxy "proxy-url"
534
535	Sets the default proxy server to use. The proxy-url must begin with a
536	string of the form C<http://host:port> (optionally C<https:...>).
537
538	=item $AnyEvent::HTTP::MAX_RECURSE
539
540	The default value for the C<recurse> request parameter (default: C<10>).
541
542	=item $AnyEvent::HTTP::USERAGENT
543
544	The default value for the C<User-Agent> header (the default is
545	C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
546
547	=item $AnyEvent::HTTP::MAX_PERSISTENT
548
549	The maximum number of persistent connections to keep open (default: 8).
550
551	Not implemented currently.
552
553	=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
554
555	The maximum time to cache a persistent connection, in seconds (default: 2).
556
557	Not implemented currently.
558
559	=item $AnyEvent::HTTP::ACTIVE
560
561	The number of active connections. This is not the number of currently
562	running requests, but the number of currently open and non-idle TCP
563	connections. This number of can be useful for load-leveling.
564
565	=back
566
567	=cut
568
569	sub set_proxy($) {
570	$PROXY = [$2, $3 \|\| 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix;
571	}
572
573	# initialise proxy from environment
574	set_proxy $ENV{http_proxy};
575
576	=head1 SEE ALSO
577
578	L<AnyEvent>.
579
580	=head1 AUTHOR
581
582	Marc Lehmann <schmorp@schmorp.de>
583	http://home.schmorp.de/
584
585	=cut
586
587	1
588