Perl6-Pugs/ext/libwww-perl/lib/HTTP/Cookies.pm
use v6-alpha;
# XXX LWP::Debug to debug things :-)
#use LWP::Debug;
use HTTP::Date <str2time time2str>;
use HTTP::Headers::Util <split_header_words join_header_words>;
class HTTP::Cookies-0.0.1 {
## Class variables
our $EPOCH_OFFSET;
## Attributes
has %!cookies is rw;
has $.file is rw;
has $.autosave is rw;
has $.ignore_discard is rw;
has $.hide_cookie2 is rw;
$EPOCH_OFFSET = 0; # difference from Unix epoch
if ($*OS eq "MacOS") {
require Time::Local;
$EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
}
## Creation and destruction
submethod BUILD (Str $.file, Bool $.autosave = 0, Bool $.ignore_discard = 0, Bool $.hide_cookie2 = 0) {
self.load();
}
submethod DESTROY () {
self.save() if $.autosave;
}
## Instance methods
method add_cookie_header (HTTP::Request $request) {
my $uri = $request.uri;
my $scheme = $uri.scheme;
unless ($scheme ~~ m:P5/^https?\z/) {
#LWP::Debug::debug('Will not add cookies to non-HTTP requests');
return;
}
my $domain = self!host($request, $uri);
$domain = "$domain\.local" unless $domain ~~ m:P5/\./;
my $secure_request = ($scheme eq 'https');
my $req_path = self!uri_path($uri);
my $req_port = $uri.port;
my $now = time();
self!normalize_path($req_path) if $req_path ~~ m:P5/%/;
my $set_ver = 0;
my $netscape_only = 0; # an exact domain match applies to "any" cookie
my @vals = gather {
loop ($domain ~~ m:P5/\./) {
#LWP::Debug::debug("Checking $domain for cookies");
my $cookies = %!cookies{$domain};
next unless $cookies;
if (.delayload && defined $cookies{'//+delayload'}) {
my $data = $cookies{''//+delayload'}{'cookie'};
%!cookies.delete($domain);
self.load_cookie($data[1]);
$cookies = %!cookies{$domain};
next unless $cookies; # should not really happen
}
# Want to add cookies corresponding to the most specific paths
# first (i.e. longest path first)
for $cookies.keys.sort:{ $^b.chars <=> $^a.chars } -> $path {
#LWP::Debug::debug("- checking cookie path=$path");
if ($req_path.index($path) != 0) {
LWP::Debug::debug(" path $path:$req_path does not fit");
next;
}
for $cookies{$path}.kv -> $key, $array {
my :($version, $val, $port, $path_spec, $secure, $expires) := $array;
#LWP::Debug::debug(" - checking cookie $key=$val");
if ($secure && $secure_request) {
#LWP::Debug::debug(" not a secure request");
next;
}
if ($expires && $expires < $now) {
#LWP::Debug::debug(" expired");
next;
}
if ($port) {
my $found;
if ($port ~~ s/^_//) {
# The correponding Set-Cookie attribute was empty
$found++ if $port eq $req_port;
$port = "";
} else {
for $port.split(',') -> $p {
$found++, $last if $p eq $req_port;
}
}
unless ($found) {
#LWP::Debug::debug(" port $port:$req_port does not fit");
next;
}
}
if ($version > 0 && $netscape_only) {
#LWP::Debug::debug(" domain $domain applies to Netscape-style cookies only");
next;
}
#LWP::Debug::debug(" it's a match");
# set version number of cookie header.
# XXX: What should it be if multiple matching
# Set-Cookie headers have different versions themselves
if (!$set_ver++) {
if ($version >= 1) {
take "\$Version=$version";
} elsif (!(.hide_cookie2)) {
$request.add_header(Cookie2 => '$Version="1"');
}
}
# do we need to quote the value
if ($val ~~ m:P5/\W/ && $version) {
$val ~~ s:P5:g/([\\\"])/\\$0/;
$val = qq("$val");
}
# and finally remember this cookie
take "$key=$val";
if ($version >= 1) {
take qq(\$Path="$path") if $path_spec;
take qq(\$Domain="$domain") if $domain ~~ m:P5/^\./;
if ($port.defined) {
my $p = '$Port';
$p ~= qq(="$port") if $port.chars;
take $p;
}
}
}
}
NEXT {
# Try with a more general domain, alternately stripping
# leading name components and leading dots. When this
# results in a domain with no leading dot, it is for
# Netscape cookie compatibility only:
#
# a.b.c.net Any cookie
# .b.c.net Any cookie
# b.c.net Netscape cookie only
# .c.net Any cookie
if ($domain ~~ s:P5/^\.+//) {
$netscape_only = 1;
} else {
$domain ~~ s:P5/[^.]*//;
$netscape_only = 0;
}
}
}
};
$request.header(Cookie => @vals.join("; ")) if @vals;
return $request;
}
method extract_cookies ($response) {
...
}
# XXX lots of potential `where /.../` clauses here :-)
method set_cookie (Num $version, Str $key, Str $val, Str $path, Str $domain, Str $port?, Bool $path_spec = Bool::False, Bool $secure = Bool::False, Num $maxage?, Bool $discard = Bool::False, *%rest) {
return self if $path !~~ m,^/, || $key ~~ m,^\$,;
if $port.defined {
return self unless $port ~~ m:P5/^_?\d+(?:,\d+)*/;
}
my $expires;
if $maxage.defined {
if $maxage <= 0 {
%!cookies{$domain}{$path}.delete($key);
return self;
}
$expires = time() + $maxage;
}
my @array = ($version, $val, $port, $path_spec, $secure, $expires, $discard);
@array.push(%rest) if %rest.keys;
@array.pop while !defined @array[-1];
%!cookies{$domain}{$path}{$key} = \@array;
return self;
}
method set_cookie_ok (*@_) { 1; }
method save (Str $file = $.file) {
my $fh = open($file, :w);
$fh.say("#LWP-Cookies-1.0");
$fh.print(self.as_string(!$.ignore_discard));
$fh.close;
1;
}
method load (Str $file = $.file) {
my $fh = open($file, :r) or return;
# XXX ensure record seperator == "\n" -- how?
my $magic = =$fh;
unless ($magic ~~ m:P5/^\#LWP-Cookies-(\d+\.\d+)/) {
warn "$file does not seem to contain cookies";
return;
}
for (=$fh) {
next unless s/^Set-Cookie3\:\s*//;
for split_header_words($_) -> @cookie {
my ($key, $val) = @cookie.splice(0, 2);
my %hash = @cookie;
my $version = %hash.delete('version');
my $path = %hash.delete('path');
my $domain = %hash.delete('domain');
my $port = %hash.delete('port');
my $expires = str2time(%hash.delete('expires'));
my $path_spec = %hash.exists('path_spec'); %hash.delete('path_spec');
my $secure = %hash.exists('secure'); %hash.delete('secure');
my $discard = %hash.exists('discard'); %hash.delete('discard');
my @array = ($version, $val, $port, $path_spec, $secure, $expires, $discard);
push @array, %hash if %hash;
%!cookies{$domain}{$path}{$key} = @array;
}
}
$fh.close;
1;
}
method revert () {
self.clear.load;
}
multi method clear () {
%!cookies = ();
self;
}
multi method clear (*@_) {
if (@_ == 1) {
%!cookies.delete(@_[0]);
} elsif (@_ == 2) {
%!cookies{@_[0]}.delete(@_[1]);
} elsif (@_ == 3) {
%!cookies{@_[0]}{@_[1]}.delete(@_[2]);
}
self;
}
method clear_temporary_cookies () {
self.scan(sub (*@_) { if (@_[9]) || (!@_[8].defined) { @_[8] = -1; self.set_cookie(|@_); } });
}
method scan (Code $callback) {
for %!cookies.keys.sort -> $domain {
for %!cookies{$domain}.keys.sort -> $path {
for %!cookies{$domain}{$path}.keys.sort -> $key is rw {
my :($version, $val, $port, $path_spec, $secure, $expires, $discard, *%rest) := @$key;
%rest //= {};
$cb.($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $expires, $discard, *%rest);
}
}
}
}
method as_string (Bool $skip_discardables?) {
# XXX use nested gather/take
my @ret = (gather {
self.scan(sub ($version, $key, $val, $path, $domain, $port?, $path_spec?, $secure?, $maxage?, $discard?, *%rest) {
return if $discard && $skip_discardables;
my @h = ($key, $val);
@h.push('path', $path);
@h.push('domain', $domain);
@h.push('port', $port) if $port.defined;
@h.push('path_spec', undef) if $path_spec;
@h.push('secure', undef) if $secure;
@h.push('expires', HTTP::Date::time2isoz($expires)) if $expires;
@h.push('discard' => undef) if $discard;
for %rest.keys.sort -> $k {
@h.push($k, %rest{$k});
}
@h.push('version', $version);
take "Set-Cookie3: " ~ join_header_words(@h);
});
take "";
}).join("\n");
}
## Class methods
# these may also be called on an instance, but they are not tied to a
# particular instance
my method host (HTTP::Request $r, URI $uri) {
if (my $h = $r.header('Host')) {
$h ~~ s:P5/:\d+$//;
return $h.lc;
}
return $uri.host.lc;
}
my method uri_path (URI $uri) {
my $path;
if ($uri.can('epath')) {
$path = $uri.epath; # URI::URL method
} else {
$path = $uri.path; # URI::_generic method
}
$path.chars || $path = "/";
return $path;
}
# XXX how should this binding be done?
#our &!url_path ::= &!uri_path; # for backwards compatibility
my method normalize_path (Str $str is rw) {
given ($str) {
s:P5:g/%([0-9a-fA-F][0-9a-fA-F])/{
my $x = $0.uc;
$x eq "2F"|"25" ?? "%$x" !! pack("C", :16($x));
}/;
s:P5:g/([\0-\x20\x7f-\xff])/{ ord($0).as('%%%02X') }/;
}
}
}