[ViewVC] Diff of: cvs/AnyEvent-HTTP/HTTP.pm

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.102 by root, Sat Feb 19 06:46:14 2011 UTC vs.
Revision 1.122 by root, Fri May 8 17:28:39 2015 UTC

 use AnyEvent::Util ();
 use AnyEvent::Handle ();
 use base Exporter::;
-our $VERSION = '2.04';
+our $VERSION = 2.21;
 our @EXPORT = qw(http_get http_post http_head http_request);
 our $USERAGENT          = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
 our $MAX_RECURSE        =  10;
 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 callback is called, the request will be cancelled.
 The callback will be called with the response body data as first argument
-(or C<undef> if an error occured), and a hash-ref with response headers
+(or C<undef> if an error occurred), and a hash-ref with response headers
 (and trailers) as second argument.
 All the headers in that hash are lowercased. In addition to the response
 headers, the "pseudo-headers" (uppercase to avoid clashing with possible
 response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
 C<590>-C<599> and the C<Reason> pseudo-header will contain an error
 message. Currently the following status codes are used:
 =over 4
-=item 595 - errors during connection etsbalishment, proxy handshake.
+=item 595 - errors during connection establishment, proxy handshake.
 =item 596 - errors during TLS negotiation, request sending and header processing.
 =item 597 - errors during body receiving or processing.
 =over 4
 =item recurse => $count (default: $MAX_RECURSE)
-Whether to recurse requests or not, e.g. on redirects, authentication
+Whether to recurse requests or not, e.g. on redirects, authentication and
-retries and so on, and how often to do so.
+other retries and so on, and how often to do so.
+Only redirects to http and https URLs are supported. While most common
+redirection forms are handled entirely within this module, some require
+the use of the optional L<URI> module. If it is required but missing, then
+the request will fail with an error.
 =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
 they won't be sent at all).
 You really should provide your own C<User-Agent:> header value that is
 appropriate for your program - I wouldn't be surprised if the default
 AnyEvent string gets blocked by webservers sooner or later.
+Also, make sure that your headers names and values do not contain any
+embedded newlines.
 =item timeout => $seconds
 The time-out to use for various stages - each connect attempt will reset
 the timeout, as will read or write activity, i.e. this is not an overall
 context) - only connections using the same unique ID will be reused.
 =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
+connect (for example, to bind it on a given IP address). This parameter
 overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
 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<AnyEvent::Socket::tcp_connect> for details.
 Example: do a HTTP HEAD request on https://www.google.com/, use a
 timeout of 30 seconds.
    http_request
-      GET     => "https://www.google.com",
+      HEAD    => "https://www.google.com",
       headers => { "user-agent" => "MySearchClient 1.0" },
       timeout => 30,
       sub {
          my ($body, $hdr) = @_;
          use Data::Dumper;
    $cb->(undef, $hdr);
    ()
 }
+our %IDEMPOTENT = (
+   DELETE		=> 1,
+   GET			=> 1,
+   HEAD			=> 1,
+   OPTIONS		=> 1,
+   PUT			=> 1,
+   TRACE		=> 1,
+   ACL			=> 1,
+   "BASELINE-CONTROL"	=> 1,
+   BIND			=> 1,
+   CHECKIN		=> 1,
+   CHECKOUT		=> 1,
+   COPY			=> 1,
+   LABEL		=> 1,
+   LINK			=> 1,
+   MERGE		=> 1,
+   MKACTIVITY		=> 1,
+   MKCALENDAR		=> 1,
+   MKCOL		=> 1,
+   MKREDIRECTREF	=> 1,
+   MKWORKSPACE		=> 1,
+   MOVE			=> 1,
+   ORDERPATCH		=> 1,
+   PROPFIND		=> 1,
+   PROPPATCH		=> 1,
+   REBIND		=> 1,
+   REPORT		=> 1,
+   SEARCH		=> 1,
+   UNBIND		=> 1,
+   UNCHECKOUT		=> 1,
+   UNLINK		=> 1,
+   UNLOCK		=> 1,
+   UPDATE		=> 1,
+   UPDATEREDIRECTREF	=> 1,
+   "VERSION-CONTROL"	=> 1,
+);
 sub http_request($$@) {
    my $cb = pop;
    my ($method, $url, %arg) = @_;
    my %hdr;
    $hdr{"user-agent"} = $USERAGENT                     unless exists $hdr{"user-agent"};
    $hdr{"content-length"} = length $arg{body}
       if length $arg{body} || $method ne "GET";
-   my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/;
+   my $idempotent = $IDEMPOTENT{$method};
    # default value for keepalive is true iff the request is for an idempotent method
-   my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : $idempotent;
+   my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
-   my $keepalive10 = exists $arg{keepalive10} ? $arg{keepalive10} : !$proxy;
+   my $keepalive  = exists $arg{keepalive}  ? !!$arg{keepalive}  : !$proxy;
-   my $keptalive; # true if this is actually a recycled connection
+   my $was_persistent; # true if this is actually a recycled connection
    # the key to use in the keepalive cache
-   my $ka_key = "$uhost\x00$arg{sessionid}";
+   my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
-   $hdr{connection} = ($keepalive ? $keepalive10 ? "keep-alive " : "" : "close ") . "Te"; #1.1
+   $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
    $hdr{te}         = "trailers" unless exists $hdr{te}; #1.1
    my %state = (connect_guard => 1);
    my $ae_error = 595; # connecting
       # send request
       $hdl->push_write (
          "$method $rpath HTTP/1.1\015\012"
          . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
          . "\015\012"
-         . (delete $arg{body})
+         . $arg{body}
       );
-      # return if error occured during push_write()
+      # return if error occurred during push_write()
       return unless %state;
       # reduce memory usage, save a kitten, also re-use it for the response headers.
       %hdr = ();
             %hdr = (%$hdr, @pseudo);
          }
          # redirect handling
-         # microsoft and other shitheads don't give a shit for following standards,
+         # relative uri handling forced by microsoft and other shitheads.
-         # try to support some common forms of broken Location headers.
+         # we give our best and fall back to URI if available.
-         if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
+         if (exists $hdr{location}) {
+            my $loc = $hdr{location};
+            if ($loc =~ m%^//%) { # //
+               $loc = "$rscheme:$loc";
+            } elsif ($loc eq "") {
+               $loc = $url;
+            } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
-            $hdr{location} =~ s/^\.\/+//;
+               $loc =~ s/^\.\/+//;
+               if ($loc !~ m%^[.?#]%) {
-            my $url = "$rscheme://$uhost:$uport";
+                  my $prefix = "$rscheme://$uhost:$uport";
-            unless ($hdr{location} =~ s/^\///) {
+                  unless ($loc =~ s/^\///) {
-               $url .= $upath;
+                     $prefix .= $upath;
-               $url =~ s/\/[^\/]*$//;
+                     $prefix =~ s/\/[^\/]*$//;
+                  }
+                  $loc = "$prefix/$loc";
+               } elsif (eval { require URI }) { # uri
+                  $loc = URI->new_abs ($loc, $url)->as_string;
+               } else {
+                  return _error %state, $cb, { @pseudo, Status => 599, Reason => "Cannot parse Location (URI module missing)" };
+                  #$hdr{Status} = 599;
+                  #$hdr{Reason} = "Unparsable Redirect (URI module missing)";
+                  #$recurse = 0;
+               }
             }
-            $hdr{location} = "$url/$hdr{location}";
+            $hdr{location} = $loc;
          }
          my $redirect;
          if ($recurse) {
             # 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.
+            # we go with the industry standard. 308 is defined
+            # by rfc7538
             if ($status == 301 or $status == 302 or $status == 303) {
+               $redirect = 1;
                # HTTP/1.1 is unclear on how to mutate the method
-               $method = "GET" unless $method eq "HEAD";
+               unless ($method eq "HEAD") {
-               $redirect = 1;
+                  $method = "GET";
+                  delete $arg{body};
+               }
-            } elsif ($status == 307) {
+            } elsif ($status == 307 or $status == 308) {
                $redirect = 1;
             }
          }
-         my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
+         my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
             if ($state{handle}) {
                # handle keepalive
                if (
-                  $keepalive
+                  $persistent
                   && $_[3]
                   && ($hdr{HTTPVersion} < 1.1
                       ? $hdr{connection} =~ /\bkeep-?alive\b/i
                       : $hdr{connection} !~ /\bclose\b/i)
                ) {
             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
+               $state{recurse} =
-               http_request (
+                  http_request (
-                  $method  => $hdr{location},
+                     $method  => $hdr{location},
-                  %arg,
+                     %arg,
-                  recurse  => $recurse - 1,
+                     recurse  => $recurse - 1,
-                  Redirect => [$_[0], \%hdr],
+                     Redirect => [$_[0], \%hdr],
+                     sub {
+                        %state = ();
-                  $cb
+                        &$cb
+                     },
-               );
+                  );
             } else {
                $cb->($_[0], \%hdr);
             }
          };
             my $body = "";
             my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
             $state{read_chunk} = sub {
                $_[1] =~ /^([0-9a-fA-F]+)/
-                  or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
+                  or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
                my $len = hex $1;
                if ($len) {
                   $cl += $len;
          }
       };
       # if keepalive is enabled, then the server closing the connection
       # before a response can happen legally - we retry on idempotent methods.
-      if ($keptalive && $idempotent) {
+      if ($was_persistent && $idempotent) {
          my $old_eof = $hdl->{on_eof};
          $hdl->{on_eof} = sub {
             _destroy_state %state;
+            %state = ();
+            $state{recurse} =
-            http_request (
+               http_request (
-               $method => $url,
+                  $method   => $url,
-               %arg,
+                  %arg,
+                  recurse   => $recurse - 1,
-               keepalive => 0,
+                  keepalive => 0,
+                  sub {
+                     %state = ();
-               $cb
+                     &$cb
+                  }
-            );
+               );
          };
          $hdl->on_read (sub {
             return unless %state;
             # as soon as we receive something, a connection close
    };
    my $prepare_handle = sub {
       my ($hdl) = $state{handle};
-      $hdl->timeout ($timeout);
       $hdl->on_error (sub {
          _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] };
       });
       $hdl->on_eof (sub {
          _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" };
       });
+      $hdl->timeout_reset;
+      $hdl->timeout ($timeout);
    };
    # connected to proxy (or origin server)
    my $connect_cb = sub {
       my $fh = shift
       # now handle proxy-CONNECT method
       if ($proxy && $uscheme eq "https") {
          # oh dear, we have to wrap it into a connect request
+         my $auth = exists $hdr{"proxy-authorization"}
+            ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
+            : "";
          # maybe re-use $uauthority with patched port?
-         $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012");
+         $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012$auth\015\012");
          $state{handle}->push_read (line => $qr_nlnl, sub {
             $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
                or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" };
             if ($2 == 200) {
             } else {
                _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
             }
          });
       } else {
+         delete $hdr{"proxy-authorization"} unless $proxy;
          $handle_actual_request->();
       }
    };
    _get_slot $uhost, sub {
       return unless $state{connect_guard};
       # try to use an existing keepalive connection, but only if we, ourselves, plan
       # on a keepalive request (in theory, this should be a separate config option).
-      if ($keepalive && $KA_CACHE{$ka_key}) {
+      if ($persistent && $KA_CACHE{$ka_key}) {
-         $keptalive = 1;
+         $was_persistent = 1;
          $state{handle} = ka_fetch $ka_key;
+         $state{handle}->destroyed
+            and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
          $prepare_handle->();
+         $state{handle}->destroyed
+            and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
          $handle_actual_request->();
       } else {
          my $tcp_connect = $arg{tcp_connect}
                            || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
 Sets the default proxy server to use. The proxy-url must begin with a
 string of the form C<http://host:port>, croaks otherwise.
 To clear an already-set proxy, use C<undef>.
-When AnyEvent::HTTP is laoded for the first time it will query the
+When AnyEvent::HTTP is loaded for the first time it will query the
 default proxy from the operating system, currently by looking at
 C<$ENV{http_proxy>}.
 =item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
 C<$session_end> is given and true, then additionally remove all session
 cookies.
 You should call this function (with a true C<$session_end>) before you
 save cookies to disk, and you should call this function after loading them
-again. If you have a long-running program you can additonally call this
+again. If you have a long-running program you can additionally call this
 function from time to time.
 A cookie jar is initially an empty hash-reference that is managed by this
-module. It's format is subject to change, but currently it is like this:
+module. Its format is subject to change, but currently it is as follows:
 The key C<version> has to contain C<1>, otherwise the hash gets
 emptied. All other keys are hostnames or IP addresses pointing to
 hash-references. The key for these inner hash references is the
 server path for which this cookie is meant, and the values are again
-hash-references. The keys of those hash-references is the cookie name, and
+hash-references. Each key of those hash-references is a cookie name, and
 the value, you guessed it, is another hash-reference, this time with the
 key-value pairs from the cookie, except for C<expires> and C<max-age>,
 which have been replaced by a C<_expires> key that contains the cookie
-expiry timestamp.
+expiry timestamp. Session cookies are indicated by not having an
+C<_expires> key.
 Here is an example of a cookie jar with a single cookie, so you have a
 chance of understanding the above paragraph:
    {
 The default value for the C<recurse> request parameter (default: C<10>).
 =item $AnyEvent::HTTP::TIMEOUT
-The default timeout for conenction operations (default: C<300>).
+The default timeout for connection operations (default: C<300>).
 =item $AnyEvent::HTTP::USERAGENT
 The default value for the C<User-Agent> header (the default is
 C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
 =item $AnyEvent::HTTP::MAX_PER_HOST
 The maximum number of concurrent connections to the same host (identified
-by the hostname). If the limit is exceeded, then the additional requests
+by the hostname). If the limit is exceeded, then additional requests
 are queued until previous connections are closed. Both persistent and
 non-persistent connections are counted in this limit.
 The default value for this is C<4>, and it is highly advisable to not
 increase it much.
 For comparison: the RFC's recommend 4 non-persistent or 2 persistent
-connections, older browsers used 2, newers (such as firefox 3) typically
+connections, older browsers used 2, newer ones (such as firefox 3)
-use 6, and Opera uses 8 because like, they have the fastest browser and
+typically use 6, and Opera uses 8 because like, they have the fastest
-give a shit for everybody else on the planet.
+browser and give a shit for everybody else on the planet.
 =item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
-The time after which idle persistent conenctions get closed by
+The time after which idle persistent connections get closed by
 AnyEvent::HTTP (default: C<3>).
 =item $AnyEvent::HTTP::ACTIVE
 The number of active connections. This is not the number of currently
    # other formats fail in the loop below
    for (0..11) {
       if ($m eq $month[$_]) {
          require Time::Local;
-         return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
+         return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
       }
    }
    undef
 }
    set_proxy $ENV{http_proxy};
 };
 =head2 SHOWCASE
-This section contaisn some more elaborate "real-world" examples or code
+This section contains some more elaborate "real-world" examples or code
 snippets.
 =head2 HTTP/1.1 FILE DOWNLOAD
 Downloading files with HTTP can be quite tricky, especially when something
 last modified time to check for file content changes, and works with many
 HTTP/1.0 servers as well, and usually falls back to a complete re-download
 on older servers.
 It calls the completion callback with either C<undef>, which means a
-nonretryable error occured, C<0> when the download was partial and should
+nonretryable error occurred, C<0> when the download was partial and should
 be retried, and C<1> if it was successful.
    use AnyEvent::HTTP;
    sub download($$$) {
       warn stat $fh;
       warn -s _;
       if (stat $fh and -s _) {
          $ofs = -s _;
-         warn "-s is ", $ofs;#d#
+         warn "-s is ", $ofs;
          $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
          $hdr{"range"} = "bytes=$ofs-";
       }
       http_get $url,

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.102 by root, Sat Feb 19 06:46:14 2011 UTC vs. Revision 1.122 by root, Fri May 8 17:28:39 2015 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.102 by root, Sat Feb 19 06:46:14 2011 UTC vs.
Revision 1.122 by root, Fri May 8 17:28:39 2015 UTC