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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.117 by root, Mon Sep 9 21:41:43 2013 UTC vs.
Revision 1.133 by root, Sat Sep 1 03:16:43 2018 UTC

 use AnyEvent::Util ();
 use AnyEvent::Handle ();
 use base Exporter::;
-our $VERSION = '2.15';
+our $VERSION = 2.24;
 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;
 =item recurse => $count (default: $MAX_RECURSE)
 Whether to recurse requests or not, e.g. on redirects, authentication and
 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
 will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
 C<$scheme> must be either missing or must be C<http> for HTTP.
 If not specified, then the default proxy is used (see
 C<AnyEvent::HTTP::set_proxy>).
+Currently, if your proxy requires authorization, you have to specify an
+appropriate "Proxy-Authorization" header in every request.
 =item body => $string
 The request body, usually empty. Will be sent as-is (future versions of
 this module might offer more options).
 =item persistent => $boolean
 Try to create/reuse a persistent connection. When this flag is set
 (default: true for idempotent requests, false for all others), then
 C<http_request> tries to re-use an existing (previously-created)
-persistent connection to the host and, failing that, tries to create a new
+persistent connection to same host (i.e. identical URL scheme, hostname,
-one.
+port and session) and, failing that, tries to create a new one.
 Requests failing in certain ways will be automatically retried once, which
 is dangerous for non-idempotent requests, which is why it defaults to off
 for them. The reason for this is because the bozos who designed HTTP/1.1
 made it impossible to distinguish between a fatal error and a normal
 # expire cookies
 sub cookie_jar_expire($;$) {
    my ($jar, $session_end) = @_;
-   %$jar = () if $jar->{version} != 1;
+   %$jar = () if $jar->{version} != 2;
    my $anow = AE::now;
    while (my ($chost, $paths) = each %$jar) {
       next unless ref $paths;
 # extract cookies from jar
 sub cookie_jar_extract($$$$) {
    my ($jar, $scheme, $host, $path) = @_;
-   %$jar = () if $jar->{version} != 1;
+   %$jar = () if $jar->{version} != 2;
+   $host = AnyEvent::Util::idn_to_ascii $host
+      if $host =~ /[^\x00-\x7f]/;
    my @cookies;
    while (my ($chost, $paths) = each %$jar) {
       next unless ref $paths;
-      if ($chost =~ /^\./) {
+      # exact match or suffix including . match
-         next unless $chost eq substr $host, -length $chost;
+      $chost eq $host or ".$chost" eq substr $host, -1 - length $chost
-      } elsif ($chost =~ /\./) {
-         next unless $chost eq $host;
-      } else {
-         next;
+         or next;
-      }
       while (my ($cpath, $cookies) = each %$paths) {
          next unless $cpath eq substr $path, 0, length $cpath;
          while (my ($cookie, $kv) = each %$cookies) {
 }
 # parse set_cookie header into jar
 sub cookie_jar_set_cookie($$$$) {
    my ($jar, $set_cookie, $host, $date) = @_;
+   %$jar = () if $jar->{version} != 2;
    my $anow = int AE::now;
    my $snow; # server-now
    for ($set_cookie) {
       my $cdom;
       my $cpath = (delete $kv{path}) || "/";
       if (exists $kv{domain}) {
-         $cdom = delete $kv{domain};
+         $cdom = $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);
+         $cdom = substr $cdom, 1; # remove initial .
       } else {
          $cdom = $host;
       }
       # store it
-      $jar->{version} = 1;
+      $jar->{version} = 2;
       $jar->{lc $cdom}{$cpath}{$name} = \%kv;
       redo if /\G\s*,/gc;
    }
 }
    my $uport = $uscheme eq "http"  ?  80
              : $uscheme eq "https" ? 443
              : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
-   $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
+   $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
       or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
    my $uhost = lc $1;
    $uport = $2 if defined $2;
    my $was_persistent; # true if this is actually a recycled connection
    # the key to use in the keepalive cache
    my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
-   $hdr{connection} = ($persistent ? $keepalive ? "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 occurred during push_write()
       return unless %state;
             %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 = "$uscheme:$loc";
+            } elsif ($loc eq "") {
+               $loc = $url;
+            } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
-            $hdr{location} =~ s/^\.\/+//;
+               $loc =~ s/^\.\/+//;
-            my $url = "$rscheme://$uhost:$uport";
+               if ($loc !~ m%^[.?#]%) {
+                  my $prefix = "$uscheme://$uauthority";
-            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[, $persistent])
             $finish->(delete $state{handle});
          } elsif ($chunked) {
             my $cl = 0;
             my $body = "";
-            my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
+            my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
             $state{read_chunk} = sub {
                $_[1] =~ /^([0-9a-fA-F]+)/
                   or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
                }
             };
             $_[0]->push_read (line => $state{read_chunk});
-         } elsif ($arg{on_body}) {
+         } elsif (!$redirect && $arg{on_body}) {
             if (defined $len) {
                $_[0]->on_read (sub {
                   $len -= length $_[0]{rbuf};
                   $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
             _destroy_state %state;
             %state = ();
             $state{recurse} =
                http_request (
-                  $method   => $url,
+                  $method    => $url,
                   %arg,
-                  recurse   => $recurse - 1,
+                  recurse    => $recurse - 1,
-                  keepalive => 0,
+                  persistent => 0,
                   sub {
                      %state = ();
                      &$cb
                   }
                );
       # 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 {
       # on a keepalive request (in theory, this should be a separate config option).
       if ($persistent && $KA_CACHE{$ka_key}) {
          $was_persistent = 1;
          $state{handle} = ka_fetch $ka_key;
-         $state{handle}->destroyed
+#         $state{handle}->destroyed
-            and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
+#            and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
          $prepare_handle->();
-         $state{handle}->destroyed
+#         $state{handle}->destroyed
-            and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
+#            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 };
 save cookies to disk, and you should call this function after loading them
 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
+The key C<version> has to contain C<2>, otherwise the hash gets
-emptied. All other keys are hostnames or IP addresses pointing to
+cleared. 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. 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>,
 Here is an example of a cookie jar with a single cookie, so you have a
 chance of understanding the above paragraph:
    {
-      version    => 1,
+      version    => 2,
       "10.0.0.1" => {
          "/" => {
             "mythweb_id" => {
               _expires => 1293917923,
               value    => "ooRung9dThee3ooyXooM1Ohm",
 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.
          or die "$file: $!";
       my %hdr;
       my $ofs = 0;
-      warn stat $fh;
-      warn -s _;
       if (stat $fh and -s _) {
          $ofs = -s _;
          warn "-s is ", $ofs;
          $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
          $hdr{"range"} = "bytes=$ofs-";
             my (undef, $hdr) = @_;
             my $status = $hdr->{Status};
             if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
-               utime $fh, $time, $time;
+               utime $time, $time, $fh;
             }
             if ($status == 200 || $status == 206 || $status == 416) {
                # download ok || resume ok || file already fully downloaded
                $cb->(1, $hdr);

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.117 by root, Mon Sep 9 21:41:43 2013 UTC vs. Revision 1.133 by root, Sat Sep 1 03:16:43 2018 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.117 by root, Mon Sep 9 21:41:43 2013 UTC vs.
Revision 1.133 by root, Sat Sep 1 03:16:43 2018 UTC