--- AnyEvent-HTTP/HTTP.pm 2010/12/31 19:32:47 1.69 +++ AnyEvent-HTTP/HTTP.pm 2011/01/01 02:20:49 1.76 @@ -185,18 +185,18 @@ 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 -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 working. Cookies are a privacy disaster, do not use -them unless required to. +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 +working. Cookies are a privacy disaster, do not use them unless required +to. When cookie processing is enabled, the C and C -headers will be ste and handled by this module, otherwise they will be +headers will be set and handled by this module, otherwise they will be left untouched. =item tls_ctx => $scheme | $tls_ctx @@ -366,6 +366,121 @@ _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; @@ -450,33 +565,10 @@ # cookie processing if (my $jar = $arg{cookie_jar}) { - %$jar = () if $jar->{version} != 1; - - 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 - if @cookie; + my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath; + + $hdr{cookie} = join "; ", @$cookies + if @$cookies; } my ($rhost, $rport, $rscheme, $rpath); # request host, port, path @@ -518,8 +610,6 @@ return $cb->(undef, { @pseudo, Status => 599, Reason => $err }); }; - pop; # free memory, save a tree - return unless delete $state{connect_guard}; # get handle @@ -573,7 +663,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 @@ -618,7 +708,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. @@ -632,7 +722,7 @@ } my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) - my $keepalive = pop; + my $may_keep_alive = $_[3]; $state{handle}->destroy if $state{handle}; %state = (); @@ -644,52 +734,7 @@ # set-cookie processing if ($arg{cookie_jar}) { - for ($hdr{"set-cookie"}) { - # 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; - } + cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost; } if ($redirect && exists $hdr{location}) { @@ -905,8 +950,9 @@ =item $timestamp = AnyEvent::HTTP::parse_date $date -Takes a HTTP Date (RFC 2616) 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) and +returns the corresponding POSIX timestamp, or C if the date cannot +be parsed. =item $AnyEvent::HTTP::MAX_RECURSE @@ -955,8 +1001,10 @@ 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$/) { - # RFC 822/1123, required by RFC 2616 + 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$/) {