view release on metacpan or  search on metacpan

t/CookieTest.pm  view on Meta::CPAN

sub success { return( shift->reply( Apache2::Const::HTTP_OK => 'ok' ) ); }
# From 01 to 19 those are the Apache2::SSI::URI test units
sub test01
{
    my $self = shift( @_ );
    my $token = q{eyJleHAiOjE2MzYwNzEwMzksImFsZyI6IkhTMjU2In0.eyJqdGkiOiJkMDg2Zjk0OS1mYWJmLTRiMzgtOTE1ZC1hMDJkNzM0Y2ZmNzAiLCJmaXJzdF9uYW1lIjoiSm9obiIsImlhdCI6MTYzNTk4NDYzOSwiYXpwIjoiNGQ0YWFiYWQtYmJiMy00ODgwLThlM2ItNTA0OWMwZTczNjBlIiwiaXNzIjoiaHR0cHM6...
    my $rv;
    my $jar = $self->jar;
    my $r = $self->request;
    my $c = $jar->make( name => 'session_token' => value => $token, path => '/', expires => "Monday, 01-Nov-2021 17:12:40 GMT" ) ||
    do
    {
        return( $self->ok(0) );
    };
    
    defined( $rv = $jar->set( $c ) ) || do
    {
        return( $self->ok(0) );
    };
    my @set_values = $r->err_headers_out->get( 'Set-Cookie' );
    # Need to set the call context for the regexp to scalar (boolean) so that the 'ok' method received the right value
    # Otherwise, the regexp would return nothing in list context and would render the test false even if it were true.
    return( $self->ok( "@set_values" =~ /(^|\b)session_token=$token/ ? 1 : 0 ) );
}

sub test02
{
    my $self = shift( @_ );
    my $rv;
    my $jar = $self->jar;
    my $r = $self->request;
    # For double authentication cookie scheme for example
    # See: <https://cheatsheetseries.owasp.org/cheatsheets/Cross-Site_Request_Forgery_Prevention_Cheat_Sheet.html#double-submit-cookie>
    my $csrf = q{9849724969dbcffd48c074b894c8fbda14610dc0ae62fac0f78b2aa091216e0b.1635825594};
    my $c = $jar->make( name => 'csrf_token', value => $csrf, path => '/' ) || do
    {
        return( $self->ok(0) );
    };
    # $resp->header( 'Set-Cookie' => qq{csrf_token=${csrf}; path=/} );
    defined( $rv = $jar->set( $c ) ) || do
    {
        return( $self->ok(0) );
    };
    my @set_values = $r->err_headers_out->get( 'Set-Cookie' );
    return( $self->ok( "@set_values" =~ /(^|\b)csrf_token=$csrf/ ? 1 : 0 ) );
}

sub test03
{
    my $self = shift( @_ );
    my $jar = $self->jar;
    return( $self->ok( $jar->exists( 'session_token' ) && $jar->exists( 'csrf_token' ) ) );
}

sub test04
{
    my $self = shift( @_ );
    my $rv;
    my $jar = $self->jar;
    my $r = $self->request;
    my $c = $jar->make( name => 'site_prefs', value => "lang=en-GB", path => '/account' ) || do
    {
        return( $self->ok(0) );
    };
    defined( $rv = $jar->set( $c ) ) || do
    {
        return( $self->ok(0) );
    };
    my @set_values = $r->err_headers_out->get( 'Set-Cookie' );
    return( $self->ok( "@set_values" =~ /(^|\b)site_prefs=lang%3Den-GB/ ? 1 : 0 ) );
}

# Check we have received 2 cookies and not 3.
# The 3rd one is only sent in a sub folder.
sub test05
{
    my $self = shift( @_ );
    my $jar = $self->jar;
    return( $self->ok( $jar->exists( 'session_token' ) && $jar->exists( 'csrf_token' ) ) );
}

sub test06
{
    my $self = shift( @_ );
    my $rv;
    my $jar = $self->jar;
    my $csrf = $jar->get( 'csrf_token' ) || do
    {
        return( $self->ok(0) );
    };
    # To properly elapse the cookie, it needs to have the same property values
    $csrf->elapse;
    $csrf->path( '/' );
    defined( $rv = $jar->set( $csrf ) ) || do
    {
        return( $self->ok(0) );
    };
    return( $self->ok( $jar->exists( 'site_prefs' ) ) );
}

sub test07
{
    my $self = shift( @_ );
    my $rv;
    my $r = $self->request;
    my $jar  = $self->jar;
    my $c = $jar->make(
        name      => 'secret_cookie',
        value     => 'My big secret',
        path      => '/',
        expires   => '+10d',
        secure    => HAS_SSL,
        http_only => 1,
        same_site => 'Lax',
        key       => $CRYPT_KEY,
        algo      => 'AES',
        encrypt   => 1,
        # We declare it, because we need to reproduce it for checking
        iv        => $CRYPT_IV,
        debug     => $self->{debug},
    );
    defined( $c ) || do
    {
        return( $self->ok(0) );
    };
    
    defined( $rv = $jar->set( $c ) ) || do
    {
        return( $self->ok(0) );
    };
    # return( $self->ok( $jar->exists( 'secret_cookie' ) ) );
    my @set_values = $r->err_headers_out->get( 'Set-Cookie' );
    return( $self->ok( "@set_values" =~ /(^|\b)secret_cookie=/ ? 1 : 0 ) );
}

sub test08
{
    my $self = shift( @_ );
    my $jar  = $self->jar;
    my $c = $jar->get( 'secret_cookie' ) || do
    {
        return( $self->ok(0) );
    };
    my $val = $c->value;
    if( !$val->length )
    {
        return( $self->ok(0) );
    }
    my $rv = $c->decrypt( key => $CRYPT_KEY, iv => $CRYPT_IV, algo => 'AES' );
    if( !defined( $rv ) )
    {
        return( $self->ok(0) );
    }
    return( $self->ok(1) );
}

# Same as test08, except that the test should not pass
# So if we cannot decrypt the value, it is ok