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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.77 by root, Sat Jan 1 19:13:41 2011 UTC vs.
Revision 1.81 by root, Sun Jan 2 01:20:17 2011 UTC

 =item 595 - errors during connection etsbalishment, proxy handshake.
 =item 596 - errors during TLS negotiation, request sending and header processing.
-=item 597 - errors during body receive or processing.
+=item 597 - errors during body receiving or processing.
-=item 598 - user aborted request in C<on_header> or C<on_body>.
+=item 598 - user aborted request via C<on_header> or C<on_body>.
 =item 599 - other, usually nonretryable, errors (garbled URL etc.).
 =back
 =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
+The C<$hash_ref> must be an (initially empty) hash reference which
-get updated automatically. It is possible to save the cookie jar to
+will get updated automatically. It is possible to save the cookie jar
-persistent storage with something like JSON or Storable, but this is not
+to persistent storage with something like JSON or Storable - see the
-recommended, as session-only cookies might survive longer than expected.
+C<AnyEvent::HTTP::cookie_jar_expire> function if you wish to remove
+expired or session-only cookies, and also for documentation on the format
+of the cookie jar.
 Note that this cookie implementation is not meant to be complete. If
 you want complete cookie management you have to do that on your
-own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites
+own. C<cookie_jar> is meant as a quick fix to get most cookie-using sites
 working. Cookies are a privacy disaster, do not use them unless required
 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
    push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
    _slot_schedule $_[0];
 }
+#############################################################################
+# expire cookies
+sub cookie_jar_expire($;$) {
+   my ($jar, $session_end) = @_;
+   %$jar = () if $jar->{version} != 1;
+   my $anow = AE::now;
+   while (my ($chost, $paths) = each %$jar) {
+      next unless ref $paths;
+      while (my ($cpath, $cookies) = each %$paths) {
+         while (my ($cookie, $kv) = each %$cookies) {
+            if (exists $kv->{_expires}) {
+               delete $cookies->{$cookie}
+                  if $anow > $kv->{_expires};
+            } elsif ($session_end) {
+               delete $cookies->{$cookie};
+            }
+         }
+         delete $paths->{$cpath}
+            unless %$cookies;
+      }
+      delete $jar->{$chost}
+         unless %$paths;
+   }
+}
 # extract cookies from jar
 sub cookie_jar_extract($$$$) {
    my ($jar, $uscheme, $uhost, $upath) = @_;
    %$jar = () if $jar->{version} != 1;
          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 (exists $kv->{_expires} and AE::now > $kv->{_expires}) {
-               if (AE::now > parse_date ($kv->{expires})) {
-                  delete $cookies->{$cookie};
+               delete $cookies->{$cookie};
-                  next;
+               next;
-               }
             }
             my $value = $kv->{value};
             if ($value =~ /[=;,[:space:]]/) {
    \@cookies
 }
 # parse set_cookie header into jar
-sub cookie_jar_set_cookie($$$) {
+sub cookie_jar_set_cookie($$$$) {
-   my ($jar, $set_cookie, $uhost) = @_;
+   my ($jar, $set_cookie, $uhost, $date) = @_;
+   my $anow = int AE::now;
+   my $snow; # server-now
    for ($set_cookie) {
       # parse NAME=VALUE
       my @kv;
+      # expires is not http-compliant in the original cookie-spec,
+      # we support the official date format and some extensions
       while (
          m{
             \G\s*
             (?:
-               expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
+               expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
                | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
             )
          }gcxsi
       ) {
          my $name = $2;
       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"};
+      if (exists $kv{"max-age"}) {
+         $kv{_expires} = $anow + delete $kv{"max-age"};
+      } elsif (exists $kv{expires}) {
+         $snow ||= parse_date ($date) || $anow;
+         $kv{_expires} = $anow + (parse_date (delete $kv{expires}) - $snow);
+      } else {
+         delete $kv{_expires};
+      }
       my $cdom;
       my $cpath = (delete $kv{path}) || "/";
       if (exists $kv{domain}) {
                      $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
                   }
                   # set-cookie processing
                   if ($arg{cookie_jar}) {
-                     cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
+                     cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
                   }
                   if ($redirect && exists $hdr{location}) {
                      # we ignore any errors, as it is very common to receive
                      # Content-Length != 0 but no actual body
                   } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
                      my $cl = 0;
                      my $body = undef;
                      my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
-                     my $read_chunk; $read_chunk = sub {
+                     $state{read_chunk} = sub {
                         $_[1] =~ /^([0-9a-fA-F]+)/
                            or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
                         my $len = hex $1;
                                  or return $finish->(undef, 598 => "Request cancelled by on_body");
                               $_[0]->push_read (line => sub {
                                  length $_[1]
                                     and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
-                                 $_[0]->push_read (line => $read_chunk);
+                                 $_[0]->push_read (line => $state{read_chunk});
                               });
                            });
                         } else {
                            $hdr{"content-length"} ||= $cl;
                               $finish->($body, undef, undef, 1);
                            });
                         }
                      };
-                     $_[0]->push_read (line => $read_chunk);
+                     $_[0]->push_read (line => $state{read_chunk});
                   } elsif ($arg{on_body}) {
                      if ($len) {
                         $_[0]->on_read (sub {
                            $len -= length $_[0]{rbuf};
                $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
                   or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
                if ($2 == 200) {
                   $rpath = $upath;
-                  &$handle_actual_request;
+                  $handle_actual_request->();
                } else {
                   %state = ();
                   $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
                }
             });
          } else {
-            &$handle_actual_request;
+            $handle_actual_request->();
          }
       };
       my $tcp_connect = $arg{tcp_connect}
                         || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
 string of the form C<http://host:port> (optionally C<https:...>), croaks
 otherwise.
 To clear an already-set proxy, use C<undef>.
+=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
+Remove all cookies from the cookie jar that have been expired. If
+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
+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:
+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
+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.
+Here is an example of a cookie jar with a single cookie, so you have a
+chance of understanding the above paragraph:
+   {
+      version    => 1,
+      "10.0.0.1" => {
+         "/" => {
+            "mythweb_id" => {
+              _expires => 1293917923,
+              value    => "ooRung9dThee3ooyXooM1Ohm",
+            },
+         },
+      },
+   }
 =item $date = AnyEvent::HTTP::format_date $timestamp
 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) or a Cookie date (netscape cookie spec) and
+Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
-returns the corresponding POSIX timestamp, or C<undef> if the date cannot
+bunch of minor variations of those, and returns the corresponding POSIX
-be parsed.
+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 (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$/) {
+   } elsif ($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]?) GMT$/) {
       # RFC 850
       ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
-   } elsif ($date =~ /^[A-Z][a-z][a-z] ([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][0-9][0-9])$/) {
+   } elsif ($date =~ /^[A-Z][a-z][a-z]+ ([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][0-9][0-9])$/) {
       # ISO C's asctime
       ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
    }
    # other formats fail in the loop below

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.77 by root, Sat Jan 1 19:13:41 2011 UTC vs. Revision 1.81 by root, Sun Jan 2 01:20:17 2011 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.77 by root, Sat Jan 1 19:13:41 2011 UTC vs.
Revision 1.81 by root, Sun Jan 2 01:20:17 2011 UTC