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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.109 by root, Wed Jul 27 16:11:55 2011 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.13';
+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;
 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
 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).
 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.
 =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;
    }
 }
    $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;
    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;
    $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 $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
    my $keepalive  = exists $arg{keepalive}  ? !!$arg{keepalive}  : !$proxy;
    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 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 = "$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,
-                  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 };
 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
+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. 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:
    {
-      version    => 1,
+      version    => 2,
       "10.0.0.1" => {
          "/" => {
             "mythweb_id" => {
               _expires => 1293917923,
               value    => "ooRung9dThee3ooyXooM1Ohm",
 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($$$) {
          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.109 by root, Wed Jul 27 16:11:55 2011 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.109 by root, Wed Jul 27 16:11:55 2011 UTC vs.
Revision 1.133 by root, Sat Sep 1 03:16:43 2018 UTC