view release on metacpan or  search on metacpan

t/cipher.t  view on Meta::CPAN

        my $flipped = ( ord substr $altered, -1 ) ^ 0xFF;
        substr $altered, -1, 1, chr $flipped;
        T2->is( scalar $watched->_decrypt( SID, $altered ), undef, 'an altered payload does not decrypt' );

        T2->is( scalar engine( key => q{b} x 64 )->_decrypt( SID, $blob ), undef, 'the wrong key yields nothing, not garbage' );

        # Four distinct reasons, each reported once -- not once per request, which is
        # how a log stops being readable when somebody is poking at cookies.
        T2->is( scalar @reported, 4,         'each distinct reason is reported exactly once' );
        T2->is( $reported[0][0],  'warning', 'at the level Dancer2 expects' );
        T2->like( $reported[0][1], qr/could[ ]not[ ]be[ ]read/msx, 'through log_cb' );

        $watched->_decrypt( SID, $altered ) for 1 .. 3;
        T2->is( scalar @reported, 4, 'and repeating the same failure adds nothing to the log' );
    }
);

T2->subtest_streamed(
    'the principal, with no database in sight' => sub {
        my $plain = engine();
        T2->is( $plain->principal_column,     'principal_id', 'the column has a documented default' );
        T2->is( scalar $plain->principal_key, undef,          'and principal_key is off by default' );

        my $named = engine( principal_key => 'account_id', principal_column => 'account_id' );
        T2->is( $named->_principal_of( { account_id => 4711 } ), 4711,  'a named key is copied' );
        T2->is( scalar $named->_principal_of( {} ),              undef, 'a missing one gives undef' );
        T2->is( scalar $named->_principal_of( { account_id => { id => 1 } } ),
            undef, 'and a reference is skipped -- only a scalar is worth indexing' );

        my $computed = engine( principal_key => sub { return $_[0]->{'user'}{'id'} } );
        T2->is( $computed->_principal_of( { user => { id => 'PRL-9' } } ),
            'PRL-9', 'a coderef can reach an identity spread over several keys' );
        T2->is( scalar $computed->_principal_of( { user => {} } ), undef, 'and gives undef when it finds nothing' );
    }
);

# principal_key pointing at a structure leaves the column NULL, which makes
# destroy_for_principal unable to find the session -- an account suspension that
# silently does not take effect. It was silent; now it is reported, once, and
# WITHOUT the value, which is session content and the reason this module
# encrypts in the first place.
T2->subtest_streamed(
    'a principal that is not a value is reported, not swallowed' => sub {
        my @logged;
        my $engine = Dancer2::Session::Pg->new(
            dbh             => sub { die "no\n" },
            dbtable         => 'sessions',
            encryption_keys => { 0 => slot( $KEY32, undef, 1 ) },
            principal_key   => 'identity',
            log_cb          => sub { push @logged, [@_]; return 1 },
        );

        T2->is( scalar $engine->_principal_of( { identity => { id => 7, token => 'SECRET' } } ),
            undef, 'a reference still yields no principal' );

        T2->is( scalar @logged, 1,         'and it is reported' );
        T2->is( $logged[0][0],  'warning', 'at warning level' );
        T2->like( $logged[0][1], qr/destroy_for_principal/msx, 'naming the consequence rather than just the symptom' );
        T2->like( $logged[0][1], qr/HASH[ ]reference/msx,      'and what it got' );
        T2->ok( index( $logged[0][1], 'SECRET' ) < 0,
            'but NOT the value -- that is session content, and some of it is credentials' );

        $engine->_principal_of( { identity => { id => $_ } } ) for 1 .. 5;
        T2->is( scalar @logged, 1, 'reported once per engine, not once per request' );
    }
);

# The warning that a supplied handle is in manual-commit mode, which the module
# issues because a session write joining somebody else's transaction is real in
# the process and absent from the database until they commit. It needs no
# THE CODEREF FORM, which is the one the documentation recommends for
# Dancer2::Plugin::Database and DBIx::Class -- and which was silent, because
# BUILD cannot call a coderef (doing so would open a connection at construction,
# the very thing the coderef form avoids) and nothing checked it later. Same
# handle, same risk, no warning.
T2->subtest_streamed(
    'manual-commit mode warns for a CODEREF handle too' => sub {
        my $handle = bless { AutoCommit => 0, RaiseError => 1 }, 'Test::Handle';

        my @warnings;
        my @logged;
        local $SIG{'__WARN__'} = sub { push @warnings, $_[0] };

        my $engine = Dancer2::Session::Pg->new(
            dbh             => sub { $handle },
            dbtable         => 'sessions',
            log_cb          => sub { push @logged, "$_[0]: $_[1]" },
            encryption_keys => { 0 => slot( $KEY32, undef, 1 ) },
        );

        T2->is( scalar @warnings, 0, 'nothing at construction -- the coderef is deliberately not called there' );

        $engine->_dbh;
        T2->is( scalar @warnings, 1, 'but the first access warns' );
        T2->like( $warnings[0], qr/AutoCommit[ ]off/msx, 'saying what the state is' );
        T2->is( scalar( grep { m/AutoCommit[ ]off/msx } @logged ), 1, 'and it reaches log_cb as well' );

        # Once per worker, not once per request: this is on the path of every
        # single session read and write.
        $engine->_dbh for 1 .. 5;
        T2->is( scalar @warnings, 1, 'and says it ONCE, however many requests follow' );
    }
);

# PostgreSQL: the engine reads one attribute off the handle, so a blessed hashref
# is a sufficient stand-in and this can be checked anywhere.
T2->subtest_streamed(
    'a supplied handle in manual-commit mode warns, once' => sub {
        my @warnings;
        local $SIG{'__WARN__'} = sub { push @warnings, $_[0] };

        Dancer2::Session::Pg->new(
            dbh             => bless( { AutoCommit => 0 }, 'Test::Handle' ),
            dbtable         => 'sessions',
            encryption_keys => { 0 => slot( $KEY32, undef, 1 ) },
        );
        T2->is( scalar @warnings, 1, 'AutoCommit off on a supplied handle warns' );
        T2->like( $warnings[0], qr/AutoCommit[ ]off/msx,                               'saying what the state is' );
        T2->like( $warnings[0], qr/not[ ]durable[ ]until[ ]the[ ]caller[ ]commits/msx, 'and what it means for a session write' );

        # BOTH routes, because they reach different places. carp reaches an engine