view release on metacpan or  search on metacpan

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

    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
        {
            diag( "Unable to load cookies from file \"$f\": ", $repo->error ) if( $DEBUG );
            skip( "Cannot load cookies", 8 );
        };
        ok( $repo->repo->size == $jar->repo->size, 'size' );
        diag( "Checking our cookie names '", $jar->repo->keys->sort->join( ',' ), "' vs the loaded repo ones '", $repo->repo->keys->sort->join( ',' ), "'." ) if( $DEBUG );
        ok( $repo->repo->keys->sort->join( ',' ) eq $jar->repo->keys->sort->join( ',' ), 'cookie names' );
        $jar->do(sub
        {
            my $c = shift( @_ );
            my $alter = $repo->get( $c->name => $c->domain );
            ok( $alter, "equivalent cookie" );
            if( !$alter )
            {
                skip( "Cannot find equivalent cookie \"" . $c->name . "\"", 1 );
            }
            ok( $c eq $alter, "cookie \"" . $c->name . "\" identical" );
        });