--- AnyEvent-HTTP/HTTP.pm 2010/12/31 22:40:54 1.74 +++ AnyEvent-HTTP/HTTP.pm 2011/01/01 21:51:22 1.80 @@ -124,9 +124,23 @@ joined together with a comma (C<,>), as per the HTTP spec. If an internal error occurs, such as not being able to resolve a hostname, -then C<$data> will be C, C<< $headers->{Status} >> will be C<59x> -(usually C<599>) and the C pseudo-header will contain an error -message. +then C<$data> will be C, C<< $headers->{Status} >> will be +C<590>-C<599> and the C 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 596 - errors during TLS negotiation, request sending and header processing. + +=item 597 - errors during body receiving or processing. + +=item 598 - user aborted request via C or C. + +=item 599 - other, usually nonretryable, errors (garbled URL etc.). + +=back A typical callback might look like this: @@ -184,14 +198,16 @@ 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 -persistent storage with something like JSON or Storable, but this is not -recommended, as session-only cookies might survive longer than expected. +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 persistent storage with something like JSON or Storable - see the +C 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 is meant as a quick fix to get some cookie-using sites +own. C 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. @@ -366,6 +382,38 @@ _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) = @_; @@ -391,11 +439,9 @@ 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; - } + if (exists $kv->{_expires} and AE::now > $kv->{_expires}) { + delete $cookies->{$cookie}; + next; } my $value = $kv->{value}; @@ -414,18 +460,23 @@ } # parse set_cookie header into jar -sub cookie_jar_set_cookie($$$) { - my ($jar, $set_cookie, $uhost) = @_; +sub cookie_jar_set_cookie($$$$) { + 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 @@ -453,8 +504,14 @@ 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}) || "/"; @@ -602,16 +659,16 @@ return unless $state{connect_guard}; + my $ae_error = 595; # connecting + my $connect_cb = sub { $state{fh} = shift or do { my $err = "$!"; %state = (); - return $cb->(undef, { @pseudo, Status => 599, Reason => $err }); + return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err }); }; - pop; # free memory, save a tree - return unless delete $state{connect_guard}; # get handle @@ -623,11 +680,11 @@ timeout => $timeout, on_error => sub { %state = (); - $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] }); + $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] }); }, on_eof => sub { %state = (); - $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" }); + $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" }); }, ; @@ -645,6 +702,8 @@ # handle actual, non-tunneled, request my $handle_actual_request = sub { + $ae_error = 596; # request phase + $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; # send request @@ -665,7 +724,7 @@ 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 @@ -710,7 +769,7 @@ 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. @@ -736,7 +795,7 @@ # 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}) { @@ -754,6 +813,8 @@ } }; + $ae_error = 597; # body phase + my $len = $hdr{"content-length"}; if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { @@ -784,11 +845,9 @@ 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 { $_[1] =~ /^([0-9a-fA-F]+)/ - or $finish->(undef, 599 => "Garbled chunked transfer encoding"); + or $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); my $len = hex $1; @@ -801,7 +860,7 @@ $_[0]->push_read (line => sub { length $_[1] - and return $finish->(undef, 599 => "Garbled chunked transfer encoding"); + and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); $_[0]->push_read (line => $read_chunk); }); }); @@ -814,7 +873,7 @@ y/\015//d; # weed out any \015, as they show up in the weirdest of places. my $hdr = parse_hdr - or return $finish->(undef, 599 => "Garbled response trailers"); + or return $finish->(undef, $ae_error => "Garbled response trailers"); %hdr = (%hdr, %$hdr); } @@ -828,8 +887,6 @@ $_[0]->push_read (line => $read_chunk); } elsif ($arg{on_body}) { - $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) }); - if ($len) { $_[0]->on_read (sub { $len -= length $_[0]{rbuf}; @@ -853,7 +910,6 @@ $_[0]->on_eof (undef); if ($len) { - $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) }); $_[0]->on_read (sub { $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1) if $len <= length $_[0]{rbuf}; @@ -862,7 +918,7 @@ $_[0]->on_error (sub { ($! == Errno::EPIPE || !$!) ? $finish->(delete $_[0]{rbuf}) - : $finish->(undef, 599 => $_[2]); + : $finish->(undef, $ae_error => $_[2]); }); $_[0]->on_read (sub { }); } @@ -945,6 +1001,45 @@ To clear an already-set proxy, use C. +=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 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 and C, +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 @@ -952,9 +1047,9 @@ =item $timestamp = AnyEvent::HTTP::parse_date $date -Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and -returns the corresponding POSIX timestamp, or C if the date cannot -be parsed. +Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a +bunch of minor variations of those, and returns the corresponding POSIX +timestamp, or C if the date cannot be parsed. =item $AnyEvent::HTTP::MAX_RECURSE @@ -1003,17 +1098,17 @@ 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); }