view release on metacpan or  search on metacpan

t/004_cookies.t  view on Meta::CPAN

#!perl
BEGIN
{
    use strict;
    use warnings;
    use lib './lib';
    use Test::More;
    use vars qw( $DEBUG $CRYPTX_REQUIRED_VERSION );
    # 2021-11-01T08:12:10
    use Test::Time time => 1635754330;
    use HTTP::Request ();
    use HTTP::Response ();
    our $CRYPTX_REQUIRED_VERSION = '0.074';
    our $DEBUG = exists( $ENV{AUTHOR_TESTING} ) ? $ENV{AUTHOR_TESTING} : 0;
};

BEGIN
{
    use_ok( 'Cookie' );
    use_ok( 'Cookie::Jar' );
    require( "./t/env.pl" ) if( -e( "t/env.pl" ) );
};

use strict;
use warnings;

subtest 'methods' => sub
{
    my $jar = Cookie::Jar->new;
    isa_ok( $jar, 'Cookie::Jar' );

    # To generate this list:
    # perl -lnE '/^sub (?!init|[A-Z]|_)/ and say "can_ok( \$jar, \''", [split(/\s+/, $_)]->[1], "\'' );"' ./lib/Cookie/Jar.pm
    can_ok( $jar, "init" );
    can_ok( $jar, "add" );
    can_ok( $jar, "add_cookie_header" );
    can_ok( $jar, "add_request_header" );
    can_ok( $jar, "add_response_header" );
    can_ok( $jar, "delete" );
    can_ok( $jar, "do" );
    can_ok( $jar, "exists" );
    can_ok( $jar, "extract" );
    can_ok( $jar, "extract_cookies" );
    can_ok( $jar, "extract_one" );
    can_ok( $jar, "fetch" );
    can_ok( $jar, "get" );
    can_ok( $jar, "get_by_domain" );
    can_ok( $jar, "host" );
    can_ok( $jar, "iv" );
    can_ok( $jar, "key" );
    can_ok( $jar, "load" );
    can_ok( $jar, "load_as_lwp" );
    can_ok( $jar, "load_as_mozilla" );
    can_ok( $jar, "load_as_netscape" );
    can_ok( $jar, "make" );
    can_ok( $jar, "merge" );
    can_ok( $jar, "parse" );
    can_ok( $jar, "purge" );
    can_ok( $jar, "repo" );
    can_ok( $jar, "request" );
    can_ok( $jar, "save" );
    can_ok( $jar, "save_as_lwp" );
    can_ok( $jar, "save_as_mozilla" );
    can_ok( $jar, "save_as_netscape" );
    can_ok( $jar, "scan" );
    can_ok( $jar, "set" );
};

subtest 'cookie parse' => sub
{
    my $longkey = 'x' x 1024;

t/004_cookies.t  view on Meta::CPAN

            ]
        ],
        [
            'ZZTOP=%22with%20quotes%22;', [
                { name => 'ZZTOP', value => '"with quotes"' }
            ]
        ],
        [
            'BOTH="%22internal quotes%22";', [
                { name => 'BOTH', value => '"internal quotes"'}
            ]
        ],
        [
            'EMPTYQUOTE="";', [
                { name => 'EMPTYQUOTE', value => '' }
            ]
        ],
        [
            'EMPTY=;', [
                { name => 'EMPTY', value => '' }
            ]
        ],
        [
            'BADSTART="data;', [
                { name => 'BADSTART', value => '"data' }
            ]
        ],
        [
            'BADEND=data";', [
                { name => 'BADEND', value => 'data"' }
            ]
        ],

        # disallow "," as a delimiter
        [
            'Foo=Bar; Bar=Baz,  XXX=Foo%20Bar   ; YYY=; ', [
                { name => 'Foo', value => 'Bar' },
                { name => 'Bar', value => 'Baz,  XXX=Foo Bar' },
                { name => 'YYY', value => "" }
            ]
        ], 

        [ '', [] ],
        [ undef, [] ],
    );

    my $jar = Cookie::Jar->new;
    foreach my $test ( @tests )
    {
        is_deeply( $jar->parse( $test->[0] ), $test->[1], $test->[0] );
    }
};

subtest 'cookie jar' => sub
{
    $Cookie::Jar::COOKIES_DEBUG = $DEBUG;
    # For server repository
    my $srv = Cookie::Jar->new( debug => $DEBUG );
    # For client repository
    my $jar = Cookie::Jar->new( debug => $DEBUG );
    my $req = HTTP::Request->new( GET => 'https://www.example.com/' );
    $req->header( Host => 'www.example.com' );
    my $resp = HTTP::Response->new( 200 => 'OK' );
    $resp->request( $req );
    my $token = q{eyJleHAiOjE2MzYwNzEwMzksImFsZyI6IkhTMjU2In0.eyJqdGkiOiJkMDg2Zjk0OS1mYWJmLTRiMzgtOTE1ZC1hMDJkNzM0Y2ZmNzAiLCJmaXJzdF9uYW1lIjoiSm9obiIsImlhdCI6MTYzNTk4NDYzOSwiYXpwIjoiNGQ0YWFiYWQtYmJiMy00ODgwLThlM2ItNTA0OWMwZTczNjBlIiwiaXNzIjoiaHR0cHM6...
    # 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 $rv;
    my $session_cookie = $srv->make( name => 'session_token' => value => $token, path => '/', expires => "Monday, 01-Nov-2021 17:12:40 GMT" ) ||
    do
    {
        diag( "Unable to create cookie session_token: ", $srv->error ) if( $DEBUG );
    };
    
    # $resp->header( 'Set-Cookie' => qq{session_token=${token}; path=/ ; expires=Monday, 01-Nov-2021 17:12:40 GMT} );
    $rv = $srv->set( $session_cookie, response => $resp ) || do
    {
        diag( "set returned an error: ", $srv->error ) if( $DEBUG );
    };
    $rv = $jar->extract( $resp ) || do
    {
        diag( "extract returned an error: ", $jar->error ) if( $DEBUG );
    };
    $rv = $jar->add_request_header( $req );
    if( !defined( $rv ) )
    {
        diag( "add_request_header returned an error: ", $jar->error ) if( $DEBUG );
    }
    ok( $rv, 'add_request_header' );
    is( $req->header( 'Cookie' ), "session_token=$token" );
    
    $req = HTTP::Request->new( GET => 'https://www.example.com/' );
    $req->header( Host => 'www.example.com' );
    $resp = HTTP::Response->new( 200 => 'OK' );
    $resp->request( $req );
    my $csrf_cookie = $srv->make( name => 'csrf_token', value => $csrf, path => '/' ) || do
    {
        diag( "Unable to create cookie: ", $srv->error ) if( $DEBUG );
    };
    # $resp->header( 'Set-Cookie' => qq{csrf_token=${csrf}; path=/} );
    $rv = $srv->set( $csrf_cookie, response => $resp ) || do
    {
        diag( "set returned an error: ", $srv->error ) if( $DEBUG );
    };
    $rv = $jar->extract( $resp ) || do
    {
        diag( "extract returned an error: ", $jar->error ) if( $DEBUG );
    };
    
    $req = HTTP::Request->new( GET => 'https://www.example.com/foo/bar' );
    $req->header( Host => 'www.example.com' );
    $rv = $jar->add_request_header( $req );
    if( !defined( $rv ) )
    {
        diag( "add_request_header returned an error: ", $jar->error ) if( $DEBUG );
    }

    my $h = $req->header( 'Cookie' );
    like( $h, qr/session_token=${token}/ );
    like( $h, qr/csrf_token=${csrf}/ );
    
    $resp = HTTP::Response->new( 200 => 'OK' );
    $resp->request( $req );
    # $resp->header( 'Set-Cookie' => qq{site_prefs=lang%3Den-GB; path=/account} );
    my $prefs_cookie = $srv->make( name => 'site_prefs', value => "lang=en-GB", path => '/account' ) || do
    {
        diag( "Unable to add cookie site_prefs: ", $srv->error ) if( $DEBUG );
    };
    $rv = $srv->set( $prefs_cookie, response => $resp ) || do
    {
        diag( "set returned an error: ", $srv->error ) if( $DEBUG );
    };
    $rv = $jar->extract( $resp ) || do
    {
        diag( "extract returned an error: ", $jar->error ) if( $DEBUG );
    };
    
    $req = HTTP::Request->new( GET => 'https://www.example.com/' );
    $req->header( Host => 'www.example.com' );
    $rv = $jar->add_request_header( $req );
    if( !defined( $rv ) )
    {
        diag( "add_request_header returned an error: ", $jar->error ) if( $DEBUG );
    }
    $h = $req->header( 'Cookie' );
    diag( "HTTP request is: ", $req->as_string ) if( $DEBUG );
    like( $h, qr/session_token=${token}/ );
    like( $h, qr/csrf_token=${csrf}/ );
    unlike( $h, qr/site_prefs=lang%3Den-GB/ );
    
    $req = HTTP::Request->new( GET => 'https://www.example.com/account/images/' );
    $req->header( Host => 'www.example.com' );
    $rv = $jar->add_request_header( $req );
    if( !defined( $rv ) )
    {
        diag( "add_request_header returned an error: ", $jar->error ) if( $DEBUG );
    }
    $h = $req->header( 'Cookie' );
    diag( "HTTP request is: ", $req->as_string ) if( $DEBUG );
    like( $h, qr/session_token=${token}/ );
    like( $h, qr/csrf_token=${csrf}/ );
    like( $h, qr/site_prefs=lang%3Den-GB/ );
    
    # my $csrf_cookie = $jar->make( name => 'csrf_token', path => '/' )->elapse;
    $rv = $srv->fetch( request => $req ) || do
    {
        diag( "fetch returned an error: ", $srv->error ) if( $DEBUG );
    };
    $csrf_cookie = $srv->get( csrf_token => 'example.com' );
    ok( $csrf_cookie );
    if( !defined( $csrf_cookie ) )
    {
        diag( "Cannot find cookie name 'csrf_token' with host 'example.com': ", $srv->error );
    }
    $resp = HTTP::Response->new( 200 => 'OK' );
    SKIP:
    {
        if( !defined( $csrf_cookie ) )
        {
            skip( "Cannot find cookie \"csrf_cookie\".", 3 );
        }
        $csrf_cookie->elapse;
        diag( "Setting cookie csrf_token to expire: ", $csrf_cookie->as_string ) if( $DEBUG );
        # Set the Set-Cookie header fields
        $rv = $srv->set( $csrf_cookie, response => $resp ) || do
        {
            diag( "set returned an error: ", $srv->error ) if( $DEBUG );
        };
        diag( "Response header is now: ", $resp->as_string ) if( $DEBUG );
        $req = HTTP::Request->new( GET => 'https://www.example.com/account/' );
        $req->header( Host => 'www.example.com' );
        $resp->request( $req );
        # Extract them
        $rv = $jar->extract( $resp ) || do
        {
            diag( "extract returned an error: ", $jar->error ) if( $DEBUG );
        };
        # Add them back to the client request object
        $rv = $jar->add_request_header( $req );
        if( !defined( $rv ) )
        {
            diag( "add_request_header returned an error: ", $jar->error ) if( $DEBUG );
        }
        $h = $req->header( 'Cookie' );
        like( $h, qr/session_token=${token}/ );
        # should not be here anymore
        unlike( $h, qr/csrf_token=${csrf}/ );
        like( $h, qr/site_prefs=lang%3Den-GB/ );
    };
};

subtest 'extract one cookie' => sub
{
    my $jar = Cookie::Jar->new( debug => $DEBUG );
    my $cookie_str = q{session_token=fe3fc36d-4104-4cd1-8f07-56cb96b2c78b; path=/ ; expires=Monday, 01-Nov-2021 17:12:40 GMT};
    my $co = $jar->extract_one( $cookie_str, { port => 443, host => 'www.example.com' } );
    ok( $co );
    SKIP:
    {
        if( !defined( $co ) )
        {
            skip( "Cannot parse cookie string.", 1 );
        }
        is( $co->name, 'session_token', 'name' );
        is( $co->value, 'fe3fc36d-4104-4cd1-8f07-56cb96b2c78b', 'value' );
        is( $co->path, '/', 'path' );
        is( $co->expires->iso8601, '2021-11-01T17:12:40', 'expires' );
        is( $co->port, 443, 'port' );
        is( $co->domain, 'example.com', 'domain' );
    };
};

subtest 'save and load' => sub
{
    my $jar = Cookie::Jar->new( debug => $DEBUG );
    $jar->add( name => 'cookie1', value => 'value1', path => '/', domain => 'example.com', secure => 1 );
    $jar->add( name => 'cookie2', value => 'value2', path => '/account', domain => 'api.example.com', secure => 1, http_only => 1 );
    $jar->add( name => 'cookie3', value => 'value3', path => '/', domain => 'img.example.com', secure => 1 );
    my $f = $jar->new_file( __FILE__ )->parent->child( 'cookies.json' );
    diag( "Saving to file '$f'" ) if( $DEBUG );
    SKIP:
    {
        $jar->save( $f ) || do
        {
            diag( "Unable to save to file \"$f\": ", $jar->error ) if( $DEBUG );
            skip( "Cannot save file", 9 );
        };
        ok( $f->size > 0, 'Saved json file size' );
        my $repo = Cookie::Jar->new( debug => $DEBUG );
        $repo->load( $f ) || do