--- AnyEvent-HTTP/HTTP.pm 2009/08/11 13:20:42 1.50 +++ AnyEvent-HTTP/HTTP.pm 2010/11/14 20:23:00 1.58 @@ -43,14 +43,14 @@ use Errno (); -use AnyEvent 4.8 (); +use AnyEvent 5.0 (); use AnyEvent::Util (); use AnyEvent::Socket (); use AnyEvent::Handle (); use base Exporter::; -our $VERSION = '1.42'; +our $VERSION = '1.46'; our @EXPORT = qw(http_get http_post http_head http_request); @@ -94,17 +94,29 @@ When called in void context, nothing is returned. In other contexts, C 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. +destroyed before the callback is called, the request will be cancelled. The callback will be called with the response body data as first argument (or C if an error occured), 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, C and C -contain the three parts of the HTTP Status-Line of the same name. The -pseudo-header C contains the original URL (which can differ from the -requested URL when following redirects). +headers, the "pseudo-headers" (uppercase to avoid clashing with possible +response headers) C, C and C contain the +three parts of the HTTP Status-Line of the same name. + +The pseudo-header C contains the actual URL (which can differ from +the requested URL when following redirects - for example, you might get +an error that your URL scheme is not supported even though your URL is a +valid http URL because it redirected to an ftp URL, in which case you can +look at the URL pseudo header). + +The pseudo-header C only exists when the request was a result +of an internal redirect. In that case it is an array reference with +the C<($data, $headers)> from the redirect response. Note that this +response could in turn be the result of a redirect itself, and C<< +$headers->{Redirect}[1]{Redirect} >> will then contain the original +response, and so on. If the server sends a header multiple times, then their contents will be joined together with a comma (C<,>), as per the HTTP spec. @@ -147,7 +159,10 @@ =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. +the timeout, as will read or write activity, i.e. this is not an overall +timeout. + +Default timeout is 5 minutes. =item proxy => [$host, $port[, $scheme]] or undef @@ -190,6 +205,15 @@ The default for this option is C, which could be interpreted as "give me the page, no matter what". +=item on_prepare => $callback->($fh) + +In rare cases you need to "tune" the socket before it is used to +connect (for exmaple, to bind it on a given IP address). This parameter +overrides the prepare callback passed to C +and behaves exactly the same way (e.g. it has to provide a +timeout). See the description for the C<$prepare_cb> argument of +C for details. + =item on_header => $callback->($headers) When specified, this callback will be called with the header hash as soon @@ -316,7 +340,6 @@ _slot_schedule $_[0]; } -our $qr_nl = qr{\015?\012}; our $qr_nlnl = qr{(? 1, sslv2 => 1 }; @@ -339,33 +362,38 @@ } } + # pseudo headers for all subsequent responses + my @pseudo = (URL => $url); + push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; + my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; - return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) + return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) if $recurse < 0; my $proxy = $arg{proxy} || $PROXY; my $timeout = $arg{timeout} || $TIMEOUT; my ($uscheme, $uauthority, $upath, $query, $fragment) = - $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; + $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 }); + : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo }); $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x - or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); + or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); my $uhost = $1; $uport = $2 if defined $2; - $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"; + $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" + unless exists $hdr{host}; $uhost =~ s/^\[(.*)\]$/$1/; - $upath .= "?$query" if length $query; + $upath .= $query if length $query; $upath =~ s%^/?%/%; @@ -418,7 +446,8 @@ $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; - $hdr{"content-length"} = length $arg{body}; + $hdr{"content-length"} = length $arg{body} + if length $arg{body} || $method ne "GET"; my %state = (connect_guard => 1); @@ -432,7 +461,7 @@ or do { my $err = "$!"; %state = (); - return $cb->(undef, { Status => 599, Reason => $err, URL => $url }); + return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); }; pop; # free memory, save a tree @@ -442,31 +471,31 @@ # get handle $state{handle} = new AnyEvent::Handle fh => $state{fh}, - timeout => $timeout, peername => $rhost, - tls_ctx => $arg{tls_ctx}; + tls_ctx => $arg{tls_ctx}, + # these need to be reconfigured on keepalive handles + timeout => $timeout, + on_error => sub { + %state = (); + $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); + }, + on_eof => sub { + %state = (); + $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); + }, + ; # 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 { +# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { +# ++$KA_COUNT{$_[1]}; +# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { +# --$KA_COUNT{$_[1]} +# }; +# $hdr{connection} = "keep-alive"; +# } else { delete $hdr{connection}; - } - - # (re-)configure handle - $state{handle}->on_error (sub { - %state = (); - $cb->(undef, { Status => 599, Reason => $_[2], URL => $url }); - }); - $state{handle}->on_eof (sub { - %state = (); - $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url }); - }); +# } $state{handle}->starttls ("connect") if $rscheme eq "https"; @@ -482,203 +511,214 @@ . (delete $arg{body}) ); - %hdr = (); # reduce memory usage, save a kitten + # return if error occured during push_write() + return unless %state; - # 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 })); + %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use - 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]") { - y/\015//d; # weed out any \015, as they show up in the weirdest of places. - - # things seen, not parsed: - # p3pP="NON CUR OTPi OUR NOR UNI" - - $hdr{lc $1} .= ",$2" - while /\G - ([^:\000-\037]*): - [\011\040]* - ((?: [^\012]+ | \012[\011\040] )*) - \012 - /gxc; + # status line and headers + $state{handle}->push_read (line => $qr_nlnl, sub { + for ("$_[1]") { + y/\015//d; # weed out any \015, as they show up in the weirdest of places. - /\G$/ - or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url })); - } + /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc + or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo })); - substr $_, 0, 1, "" - for values %hdr; + push @pseudo, + HTTPVersion => $1, + Status => $2, + Reason => $3, + ; + + # things seen, not parsed: + # p3pP="NON CUR OTPi OUR NOR UNI" + + $hdr{lc $1} .= ",$2" + while /\G + ([^:\000-\037]*): + [\011\040]* + ((?: [^\012]+ | \012[\011\040] )*) + \012 + /gxc; - # redirect handling - # microsoft and other shitheads don't give a shit for following standards, - # try to support some common forms of broken Location headers. - if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { - $hdr{location} =~ s/^\.\/+//; - - my $url = "$rscheme://$uhost:$uport"; - - unless ($hdr{location} =~ s/^\///) { - $url .= $upath; - $url =~ s/\/[^\/]*$//; - } + /\G$/ + or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo })); + } - $hdr{location} = "$url/$hdr{location}"; + # remove the "," prefix we added to all headers above + substr $_, 0, 1, "" + for values %hdr; + + # patch in all pseudo headers + %hdr = (%hdr, @pseudo); + + # redirect handling + # microsoft and other shitheads don't give a shit for following standards, + # try to support some common forms of broken Location headers. + if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { + $hdr{location} =~ s/^\.\/+//; + + my $url = "$rscheme://$uhost:$uport"; + + unless ($hdr{location} =~ s/^\///) { + $url .= $upath; + $url =~ s/\/[^\/]*$//; } - my $redirect; + $hdr{location} = "$url/$hdr{location}"; + } - if ($recurse) { - if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { - # apparently, mozilla et al. just change POST to GET here - # more research is needed before we do the same - $redirect = 1; - } elsif ($hdr{Status} == 303) { - # even http/1.1 is unclear on how to mutate the method - $method = "GET" unless $method eq "HEAD"; - $redirect = 1; - } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { - $redirect = 1; - } - } + my $redirect; - my $finish = sub { - $state{handle}->destroy if $state{handle}; - %state = (); - - # set-cookie processing - if ($arg{cookie_jar}) { - for ($_[1]{"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; - } + if ($recurse) { + my $status = $hdr{Status}; - push @kv, $name => $value; + # industry standard is to redirect POST as GET for + # 301, 302 and 303, in contrast to http/1.0 and 1.1. + # also, the UA should ask the user for 301 and 307 and POST, + # industry standard seems to be to simply follow. + # we go with the industry standard. + if ($status == 301 or $status == 302 or $status == 303) { + # HTTP/1.1 is unclear on how to mutate the method + $method = "GET" unless $method eq "HEAD"; + $redirect = 1; + } elsif ($status == 307) { + $redirect = 1; + } + } - last unless /\G\s*;/gc; + my $finish = sub { + $state{handle}->destroy if $state{handle}; + %state = (); + + # set-cookie processing + if ($arg{cookie_jar}) { + for ($_[1]{"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; } - last unless @kv; + push @kv, $name => $value; - my $name = shift @kv; - my %kv = (value => shift @kv, @kv); + last unless /\G\s*;/gc; + } - my $cdom; - my $cpath = (delete $kv{path}) || "/"; + last unless @kv; - if (exists $kv{domain}) { - $cdom = delete $kv{domain}; - - $cdom =~ s/^\.?/./; # make sure it starts with a "." + my $name = shift @kv; + my %kv = (value => shift @kv, @kv); - 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; + my $cdom; + my $cpath = (delete $kv{path}) || "/"; - redo if /\G\s*,/gc; + 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; - if ($redirect && exists $hdr{location}) { - # we ignore any errors, as it is very common to receive - # Content-Length != 0 but no actual body - # we also access %hdr, as $_[1] might be an erro - http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); - } else { - $cb->($_[0], $_[1]); + redo if /\G\s*,/gc; } - }; - - my $len = $hdr{"content-length"}; + } - if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { - $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url }); - } elsif ( - $hdr{Status} =~ /^(?:1..|[23]04)$/ - or $method eq "HEAD" - or (defined $len && !$len) - ) { - # no body - $finish->("", \%hdr); + if ($redirect && exists $hdr{location}) { + # we ignore any errors, as it is very common to receive + # Content-Length != 0 but no actual body + # we also access %hdr, as $_[1] might be an erro + http_request ( + $method => $hdr{location}, + %arg, + recurse => $recurse - 1, + Redirect => \@_, + $cb); } else { - # body handling, four different code paths - # for want_body_handle, on_body (2x), normal (2x) - # we might read too much here, but it does not matter yet (no pers. connections) - if (!$redirect && $arg{want_body_handle}) { + $cb->($_[0], $_[1]); + } + }; + + my $len = $hdr{"content-length"}; + + if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { + $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo }); + } elsif ( + $hdr{Status} =~ /^(?:1..|[23]04)$/ + or $method eq "HEAD" + or (defined $len && !$len) + ) { + # no body + $finish->("", \%hdr); + } else { + # body handling, four different code paths + # for want_body_handle, on_body (2x), normal (2x) + # we might read too much here, but it does not matter yet (no pers. connections) + if (!$redirect && $arg{want_body_handle}) { + $_[0]->on_eof (undef); + $_[0]->on_error (undef); + $_[0]->on_read (undef); + + $finish->(delete $state{handle}, \%hdr); + + } elsif ($arg{on_body}) { + $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); + if ($len) { $_[0]->on_eof (undef); - $_[0]->on_error (undef); - $_[0]->on_read (undef); + $_[0]->on_read (sub { + $len -= length $_[0]{rbuf}; - $finish->(delete $state{handle}, \%hdr); + $arg{on_body}(delete $_[0]{rbuf}, \%hdr) + or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo }); - } elsif ($arg{on_body}) { - $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); - if ($len) { - $_[0]->on_eof (undef); - $_[0]->on_read (sub { - $len -= length $_[0]{rbuf}; - - $arg{on_body}(delete $_[0]{rbuf}, \%hdr) - or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url }); - - $len > 0 - or $finish->("", \%hdr); - }); - } else { - $_[0]->on_eof (sub { - $finish->("", \%hdr); - }); - $_[0]->on_read (sub { - $arg{on_body}(delete $_[0]{rbuf}, \%hdr) - or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url }); - }); - } + $len > 0 + or $finish->("", \%hdr); + }); } else { - $_[0]->on_eof (undef); + $_[0]->on_eof (sub { + $finish->("", \%hdr); + }); + $_[0]->on_read (sub { + $arg{on_body}(delete $_[0]{rbuf}, \%hdr) + or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo }); + }); + } + } else { + $_[0]->on_eof (undef); - if ($len) { - $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); - $_[0]->on_read (sub { - $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) - if $len <= length $_[0]{rbuf}; - }); - } else { - $_[0]->on_error (sub { - $! == Errno::EPIPE || !$! - ? $finish->(delete $_[0]{rbuf}, \%hdr) - : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); - }); - $_[0]->on_read (sub { }); - } + if ($len) { + $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); + $_[0]->on_read (sub { + $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) + if $len <= length $_[0]{rbuf}; + }); + } else { + $_[0]->on_error (sub { + ($! == Errno::EPIPE || !$!) + ? $finish->(delete $_[0]{rbuf}, \%hdr) + : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); + }); + $_[0]->on_read (sub { }); } } - }); + } }); }; @@ -690,14 +730,14 @@ $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 })); + or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); if ($2 == 200) { $rpath = $upath; &$handle_actual_request; } else { %state = (); - $cb->(undef, { Status => $2, Reason => $3, URL => $url }); + $cb->(undef, { Status => $2, Reason => $3, @pseudo }); } }); } else { @@ -728,6 +768,15 @@ =back +=head2 DNS CACHING + +AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for +the actual connection, which in turn uses AnyEvent::DNS to resolve +hostnames. The latter is a simple stub resolver and does no caching +on its own. If you want DNS caching, you currently have to provide +your own default resolver (by storing a suitable resolver object in +C<$AnyEvent::DNS::RESOLVER>). + =head2 GLOBAL FUNCTIONS AND VARIABLES =over 4 @@ -735,7 +784,10 @@ =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 (optionally C). +string of the form C (optionally C), croaks +otherwise. + +To clear an already-set proxy, use C. =item $AnyEvent::HTTP::MAX_RECURSE @@ -766,11 +818,19 @@ =cut sub set_proxy($) { - $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; + if (length $_[0]) { + $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix + or Carp::croak "$_[0]: invalid proxy URL"; + $PROXY = [$2, $3 || 3128, $1] + } else { + undef $PROXY; + } } # initialise proxy from environment -set_proxy $ENV{http_proxy}; +eval { + set_proxy $ENV{http_proxy}; +}; =head1 SEE ALSO