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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.66 by root, Fri Dec 31 06:18:30 2010 UTC vs.
Revision 1.76 by root, Sat Jan 1 02:20:49 2011 UTC

 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 as
+(or C<undef> if an error occured), and a hash-ref with response headers
-second argument.
+(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
 three parts of the HTTP Status-Line of the same name. If an error occurs
 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
+The request headers to use. Currently, C<http_request> may provide its own
-own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
+C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
-and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
+will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
-suppressed by using C<undef> for these headers in which case they won't be
+(this can be suppressed by using C<undef> for these headers in which case
-sent at all).
+they won't be sent at all).
 =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
 C<$scheme> must be either missing, 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
+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
+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 expiry times are currently being ignored.
+recommended, as session-only cookies might survive longer than expected.
-Note that this cookie implementation is not of very high quality, nor
+Note that this cookie implementation is not meant to be complete. If
-meant to be complete. If you want complete cookie management you have to
+you want complete cookie management you have to do that on your
-do that on your own. C<cookie_jar> is meant as a quick fix to get some
+own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites
-cookie-using sites working. Cookies are a privacy disaster, do not use
+working. Cookies are a privacy disaster, do not use them unless required
-them unless required to.
+to.
+When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
+headers will be set and handled by this module, otherwise they will be
+left untouched.
 =item tls_ctx => $scheme | $tls_ctx
 Specifies the AnyEvent::TLS context to be used for https connections. This
 parameter follows the same rules as the C<tls_ctx> parameter to
 This callback is useful, among other things, to quickly reject unwanted
 content, which, if it is supposed to be rare, can be faster than first
 doing a C<HEAD> request.
+The downside is that cancelling the request makes it impossible to re-use
+the connection. Also, the C<on_header> callback will not receive any
+trailer (headers sent after the response body).
 Example: cancel the request unless the content-type is "text/html".
    on_header => sub {
       $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
    },
 string instead of the body data.
 It has to return either true (in which case AnyEvent::HTTP will continue),
 or false, in which case AnyEvent::HTTP will cancel the download (and call
 the completion callback with an error code of C<598>).
+The downside to cancelling the request is that it makes it impossible to
+re-use the connection.
 This callback is useful when the data is too large to be held in memory
 (so the callback writes it to a file) or when only some information should
 be extracted, or when the body should be processed incrementally.
 If you think you need this, first have a look at C<on_body>, to see if
 that doesn't solve your problem in a better way.
 =back
-Example: make a simple HTTP GET request for http://www.nethype.de/
+Example: do a simple HTTP GET request for http://www.nethype.de/ and print
+the response body.
    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
+Example: do a HTTP HEAD request on https://www.google.com/, use a
 timeout of 30 seconds.
    http_request
       GET     => "https://www.google.com",
       timeout => 30,
          use Data::Dumper;
          print Dumper $hdr;
       }
    ;
-Example: make another simple HTTP GET request, but immediately try to
+Example: do 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";
    push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
    _slot_schedule $_[0];
 }
+# extract cookies from jar
+sub cookie_jar_extract($$$$) {
+   my ($jar, $uscheme, $uhost, $upath) = @_;
+   %$jar = () if $jar->{version} != 1;
+   my @cookies;
+   while (my ($chost, $paths) = each %$jar) {
+      next unless ref $paths;
+      if ($chost =~ /^\./) {
+         next unless $chost eq substr $uhost, -length $chost;
+      } elsif ($chost =~ /\./) {
+         next unless $chost eq $uhost;
+      } else {
+         next;
+      }
+      while (my ($cpath, $cookies) = each %$paths) {
+         next unless $cpath eq substr $upath, 0, length $cpath;
+         while (my ($cookie, $kv) = each %$cookies) {
+            next if $uscheme ne "https" && exists $kv->{secure};
+            if (exists $kv->{expires}) {
+               if (AE::now > parse_date ($kv->{expires})) {
+                  delete $cookies->{$cookie};
+                  next;
+               }
+            }
+            my $value = $kv->{value};
+            if ($value =~ /[=;,[:space:]]/) {
+               $value =~ s/([\\"])/\\$1/g;
+               $value = "\"$value\"";
+            }
+            push @cookies, "$cookie=$value";
+         }
+      }
+   }
+   \@cookies
+}
+# parse set_cookie header into jar
+sub cookie_jar_set_cookie($$$) {
+   my ($jar, $set_cookie, $uhost) = @_;
+   for ($set_cookie) {
+      # parse NAME=VALUE
+      my @kv;
+      while (
+         m{
+            \G\s*
+            (?:
+               expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
+               | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
+            )
+         }gcxsi
+      ) {
+         my $name = $2;
+         my $value = $4;
+         unless (defined $name) {
+            # expires
+            $name  = "expires";
+            $value = $1;
+         } elsif (!defined $value) {
+            # quoted
+            $value = $3;
+            $value =~ s/\\(.)/$1/gs;
+         }
+         push @kv, lc $name, $value;
+         last unless /\G\s*;/gc;
+      }
+      last unless @kv;
+      my $name = shift @kv;
+      my %kv = (value => shift @kv, @kv);
+      $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
+         if exists $kv{"max-age"};
+      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
+      $jar->{version} = 1;
+      $jar->{$cdom}{$cpath}{$name} = \%kv;
+      redo if /\G\s*,/gc;
+   }
+}
 # continue to parse $_ for headers and place them into the arg
 sub parse_hdr() {
    my %hdr;
    # things seen, not parsed:
    $upath =~ s%^/?%/%;
    # cookie processing
    if (my $jar = $arg{cookie_jar}) {
-      %$jar = () if $jar->{version} != 1;
+      my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
-      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 $uscheme ne "https" && exists $v->{secure};
-               my $value = $v->{value};
-               $value =~ s/([\\"])/\\$1/g;
-               push @cookie, "$k=\"$value\"";
-            }
-         }
-      }
-      $hdr{cookie} = join "; ", @cookie
+      $hdr{cookie} = join "; ", @$cookies
-         if @cookie;
+         if @$cookies;
    }
    my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
    if ($proxy) {
    $hdr{"user-agent"} = $USERAGENT                     unless exists $hdr{"user-agent"};
    $hdr{"content-length"} = length $arg{body}
       if length $arg{body} || $method ne "GET";
-   $hdr{connection} = "close TE";
+   $hdr{connection} = "close TE"; #1.1
-   $hdr{te}         = "trailers" unless exists $hdr{te};
+   $hdr{te}         = "trailers" unless exists $hdr{te}; #1.1
    my %state = (connect_guard => 1);
    _get_slot $uhost, sub {
       $state{slot_guard} = shift;
             or do {
                my $err = "$!";
                %state = ();
                return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
             };
-         pop; # free memory, save a tree
          return unless delete $state{connect_guard};
          # get handle
          $state{handle} = new AnyEvent::Handle
 #            ++$KA_COUNT{$_[1]};
 #            $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
 #               --$KA_COUNT{$_[1]}
 #            };
 #            $hdr{connection} = "keep-alive";
-#         } else {
-#            delete $hdr{connection};
 #         }
          $state{handle}->starttls ("connect") if $rscheme eq "https";
          # handle actual, non-tunneled, request
             return unless %state;
             %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
             # status line and headers
-            $state{handle}->push_read (line => $qr_nlnl, sub {
+            $state{read_response} = sub {
-               my $keepalive = pop;
                for ("$_[1]") {
                   y/\015//d; # weed out any \015, as they show up in the weirdest of places.
-                  /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
+                  /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
                      or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
+                  # 100 Continue handling
+                  # should not happen as we don't send expect: 100-continue,
+                  # but we handle it just in case.
+                  # since we send the request body regardless, if we get an error
+                  # we are out of-sync, which we currently do NOT handle correctly.
+                  return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
+                     if $2 eq 100;
                   push @pseudo,
                      HTTPVersion => $1,
                      Status      => $2,
                      Reason      => $3,
                if ($recurse) {
                   my $status = $hdr{Status};
                   # industry standard is to redirect POST as GET for
-                  # 301, 302 and 303, in contrast to http/1.0 and 1.1.
+                  # 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
                      $redirect = 1;
                   }
                }
                my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
+                  my $may_keep_alive = $_[3];
                   $state{handle}->destroy if $state{handle};
                   %state = ();
                   if (defined $_[1]) {
                      $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
                      $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
                   }
                   # set-cookie processing
                   if ($arg{cookie_jar}) {
-                     for ($hdr{"set-cookie"}) {
+                     cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
-                        # 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;
-                           }
-                           push @kv, $name => $value;
-                           last unless /\G\s*;/gc;
-                        }
-                        last unless @kv;
-                        my $name = shift @kv;
-                        my %kv = (value => shift @kv, @kv);
-                        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;
-                        redo if /\G\s*,/gc;
-                     }
                   }
                   if ($redirect && exists $hdr{location}) {
                      # we ignore any errors, as it is very common to receive
                      # Content-Length != 0 but no actual body
                      $_[0]->on_error (undef);
                      $_[0]->on_read  (undef);
                      $finish->(delete $state{handle});
-                  } elsif ($hdr{"transfer-encoding"} =~ /chunked/) {
+                  } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
+                     my $cl = 0;
                      my $body = undef;
                      my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
                      $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
                      my $read_chunk; $read_chunk = sub {
-                        warn $_[1];#d#
                         $_[1] =~ /^([0-9a-fA-F]+)/
                            or $finish->(undef, 599 => "Garbled chunked transfer encoding");
                         my $len = hex $1;
                         if ($len) {
+                           $cl += $len;
-                           $_[0]->push_read (chunk => hex $1, sub {
+                           $_[0]->push_read (chunk => $len, sub {
                               $on_body->($_[1], \%hdr)
                                  or return $finish->(undef, 598 => "Request cancelled by on_body");
                               $_[0]->push_read (line => sub {
                                  length $_[1]
                                     and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
                                  $_[0]->push_read (line => $read_chunk);
                               });
                            });
                         } else {
+                           $hdr{"content-length"} ||= $cl;
                            $_[0]->push_read (line => $qr_nlnl, sub {
                               if (length $_[1]) {
                                  for ("$_[1]") {
                                     y/\015//d; # weed out any \015, as they show up in the weirdest of places.
                         });
                         $_[0]->on_read (sub { });
                      }
                   }
                }
-            });
+            };
+            $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
          };
          # now handle proxy-CONNECT method
          if ($proxy && $uscheme eq "https") {
             # oh dear, we have to wrap it into a connect request
 Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
 Date (RFC 2616).
 =item $timestamp = AnyEvent::HTTP::parse_date $date
-Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
+Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
-timestamp, or C<undef> if the date cannot be parsed.
+returns the corresponding POSIX timestamp, or C<undef> if the date cannot
+be parsed.
 =item $AnyEvent::HTTP::MAX_RECURSE
 The default value for the C<recurse> request parameter (default: C<10>).
 sub parse_date($) {
    my ($date) = @_;
    my ($d, $m, $y, $H, $M, $S);
-   if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9]) ([A-Z][a-z][a-z]) ([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
+   if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9])[\- ]([A-Z][a-z][a-z])[\- ]([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
-      # RFC 822/1123, required by RFC 2616
+      # RFC 822/1123, required by RFC 2616 (with " ")
+      # cookie dates (with "-")
       ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
    } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
       # RFC 850
       ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.66 by root, Fri Dec 31 06:18:30 2010 UTC vs. Revision 1.76 by root, Sat Jan 1 02:20:49 2011 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.66 by root, Fri Dec 31 06:18:30 2010 UTC vs.
Revision 1.76 by root, Sat Jan 1 02:20:49 2011 UTC