The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl
use strict;
use warnings;
use Data::Dumper ();
use Digest::SHA qw(sha256);
use MIME::Base64 qw(decode_base64);
use Test::Exception;
use Test::More tests => 5;
use constant {
      CORRECT_CRYPTO_KEY => '(」・ω・)」うー!(/・ω・)/にゃー!',
      WRONG_CTYPTO_KEY   => '(「・ω・)「'
  };
use t::make_ini {
    ini => {
        Cookie => {
            format    => 'modern',
            cryptokey => CORRECT_CRYPTO_KEY
           }
       }
  };
use Tripletail $t::make_ini::INI_FILE;

do {
    my $legacy = $TL->newSerializer({-type => 'legacy'});
    my $modern = $TL->newSerializer({-type => 'compat'})
                    ->setCryptoKey(sha256(CORRECT_CRYPTO_KEY));
    my $wrong  = $TL->newSerializer({-type => 'compat'})
                    ->setCryptoKey(sha256(WRONG_CTYPTO_KEY));
    my $plain  = $TL->newSerializer({-type => 'compat'});
    my %cookies = (
        # Legacy
        foo => $legacy->serialize({aaa => [111]}),
        # Modern (encrypted)
        bar => $modern->serialize({aaa => [333]}),
        # Modern (encrypted with a wrong key)
        baz => $wrong->serialize({aaa => [555]}),
        # Modern (plain)
        qux => $plain->serialize({aaa => [777]})
       );
    $ENV{HTTP_COOKIE} = join('; ', map {"$_=$cookies{$_}"} keys %cookies);
};

$TL->startCgi(
    -main => sub {
        my $c = $TL->getCookie;

        subtest 'reading legacy cookies' => sub {
            plan tests => 2;

            lives_and {
                my $f = $c->get('foo');
                is $f->get('aaa'), '111';
            };

            lives_ok {
                $c->set(foo => $c->get('foo')->set(aaa => 333));
            };
        };

        subtest 'reading encrypted modern cookies' => sub {
            plan tests => 2;

            lives_and {
                my $f = $c->get('bar');
                is $f->get('aaa'), '333';
            };

            lives_ok {
                $c->set(bar => $c->get('bar')->set(aaa => 444));
            };
        };

        subtest 'reading encrypted modern cookies with a wrong key' => sub {
            plan tests => 1;

            lives_and {
                is_deeply $c->get('baz')->toHash, {};
            } 'raises no error';
        };

        subtest 'reading plain modern cookies with a key' => sub {
            plan tests => 1;

            lives_and {
                is_deeply $c->get('qux')->toHash, {};
            } 'raises no error';
        };

        subtest 'writing modern cookies' => sub {
            plan tests => 6;

            my @set;
            lives_ok {
                @set = reverse sort $c->_makeSetCookies;
            };

            is scalar(@set), 2;
            like $set[0], qr{\Afoo=[A-Za-z0-9+/!=]+\z};
            like $set[1], qr{\Abar=[A-Za-z0-9+/!=]+\z};

            my $modern = $TL->newSerializer
                            ->setCryptoKey(sha256(CORRECT_CRYPTO_KEY));
            lives_and {
                is_deeply(
                    $modern->deserialize(decode_base64((split /=/, $set[0], 2)[1])),
                    {aaa => [333]}
                   );
            };
            lives_and {
                is_deeply(
                    $modern->deserialize(decode_base64((split /=/, $set[1], 2)[1])),
                    {aaa => [444]}
                   );
            };
        };
    });