use strict;
use warnings;
use Test::More tests => 18;
use lib 't/lib';
use Catalyst::Test 'TestApp';
use CGI::Util qw( unescape );
use Digest::SHA qw( sha512_base64 );
use HTTP::Cookies;
use HTTP::Date qw( str2time time2str );
{
my $res = request('/login');
my %cookies = cookies($res);
is( scalar keys %cookies, 1, 'one cookie was set' );
my $cookie = $cookies{'authen-cookie'};
ok( $cookie, 'cookie name is authen-cookie' );
is( $cookie->{path}, '/', 'cookie path is /' );
ok( !$cookie->{secure}, 'cookie path is not SSL-only' );
ok( !$cookie->{expires}, 'cookie has no expiration set' );
my $value = $cookie->{value};
is( $value->{user_id}, 42, 'user_id in cookie is 42' );
is(
$value->{MAC}, sha512_base64( 'user_id', 42, 'the knife' ),
'MAC is expected value'
);
is(
get('/user_id'), 'none',
'no user id without a cookie'
);
# Setting COOKIE in the ENV hash works for Cat 5.8, the extra parameter to
# get works for 5.9+
my $cookie_header = $res->header('Set-Cookie');
$ENV{COOKIE} = $cookie_header;
is(
get( '/user_id', { extra_env => { 'COOKIE' => $cookie_header } } ),
42,
'user_id is 42 with cookie'
);
$cookie_header =~ s/MAC&./MAC&!/;
$ENV{COOKIE} = $cookie_header;
is(
get( '/user_id', { extra_env => { 'COOKIE' => $cookie_header } } ),
'none',
'no user_id when cookie has bad MAC'
);
}
{
my $res = request('/long_login');
my %cookies = cookies($res);
my $cookie = $cookies{'authen-cookie'};
is(
$cookie->{expires}, 'Tue, 03 Mar 2020 00:00:00 GMT',
'cookie has explicit expiration in 2020'
);
}
{
my $res = request('/logout');
# Unfortunately HTTP::Cookies will just ignore a cookie with no
# value.
my $cookie = $res->header('Set-Cookie');
my ($expires) = $cookie =~ /expires=(.+)(?:;|\z)/;
like(
$cookie, qr/^authen-cookie=(.*);/,
'value is explicitly empty'
);
cmp_ok(
str2time($expires), '<', time,
'cookie has explicit expiration in the past'
);
}
{
my $res = request('/logout');
my %cookies = cookies($res);
my $cookie = $cookies{'authen-cookie'};
ok(
!keys %{ $cookie->{value} },
'cookie value is empty'
);
}
{
TestApp->config()->{authen_cookie} = {
mac_secret => 'the knife',
name => 'my-cookie',
path => '/path',
secure => 1,
# Cannot just use any random thing, because it needs to
# match the fake request associated with the response.
domain => '.local',
};
}
{
my $res = request('/login');
my %cookies = cookies($res);
my $cookie = $cookies{'my-cookie'};
ok( $cookie, 'cookie name is my-cookie' );
is( $cookie->{path}, '/path', 'cookie path is /path' );
ok( $cookie->{secure}, 'cookie path is SSL-only' );
is( $cookie->{domain}, '.local', 'cookie domain is .local' );
}
sub cookies {
my $res = shift;
my $request = HTTP::Request->new( GET => 'http://localhost/' );
$res->request($request);
my $jar = HTTP::Cookies->new();
$jar->extract_cookies($res);
my %cookies;
my $extract = sub {
my (
undef, $name, $val, $path, $domain,
undef, undef, $secure, $expires,
undef, undef
) = @_;
my %value = map { unescape($_) } split /&/, $val;
$cookies{$name} = {
value => \%value,
path => $path,
domain => $domain,
secure => $secure,
expires => ( $expires ? time2str($expires) : undef ),
};
};
$jar->scan($extract);
return %cookies;
}