The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Test::More;

use YAML;
use Test::TCP 1.13;
use File::Temp 0.22;
use LWP::UserAgent;
use HTTP::Date qw/str2time/;
use File::Spec;

sub extract_cookie {
    my ($res) = @_;
    my @cookies = $res->header('set-cookie');
    for my $c (@cookies) {
        next unless $c =~ /dancer\.session/;
        my @parts = split /;\s+/, $c;
        my %hash =
          map { my ($k, $v) = split /\s*=\s*/; $v ||= 1; (lc($k), $v) } @parts;
        $hash{expires} = str2time($hash{expires})
          if $hash{expires};
        return \%hash;
    }
    return;
}

my $tempdir = File::Temp::tempdir(CLEANUP => 1, TMPDIR => 1);

my @engines = qw(YAML Simple);

if ($ENV{DANCER_TEST_COOKIE}) {
    push @engines, "cookie";
    setting(session_cookie_key => "secret/foo*@!");
}

foreach my $engine (@engines) {

    diag "Testing engine $engine";
    Test::TCP::test_tcp(
        client => sub {
            my $port = shift;

            my $ua = LWP::UserAgent->new;
            $ua->cookie_jar({file => "$tempdir/.cookies.txt"});

            # no session cookie set if session not referenced
            my $res = $ua->get("http://127.0.0.1:$port/no_session_data");
            ok $res->is_success, "/no_session_data"
              or diag explain $res;
            my $cookie = extract_cookie($res);
            ok !$cookie, "no cookie set"
              or diag explain $cookie;

            # empty session created if session read attempted
            $res = $ua->get("http://127.0.0.1:$port/read_session");
            ok $res->is_success, "/read_session";
            $cookie = extract_cookie($res);
            ok $cookie, "session cookie set"
              or diag explain $cookie;
            my $sid1 = $cookie->{"dancer.session"};
            like $res->content, qr/name=''/, "empty session";

            # set value into session
            $res = $ua->get("http://127.0.0.1:$port/set_session/larry");
            ok $res->is_success, "/set_session/larry";
            $cookie = extract_cookie($res);
            ok $cookie, "session cookie set"
              or diag explain $cookie;

            # read value back
            $res = $ua->get("http://127.0.0.1:$port/read_session");
            ok $res->is_success, "/read_session";
            $cookie = extract_cookie($res);
            ok $cookie, "session cookie set"
              or diag explain $cookie;
            like $res->content, qr/name='larry'/, "session value looks good";

            # session cookie should persist even if we don't touch sessions
            $res = $ua->get("http://127.0.0.1:$port/no_session_data");
            ok $res->is_success, "/no_session_data";
            $cookie = extract_cookie($res);
            ok $cookie, "session cookie set"
              or diag explain $cookie;

            # destroy session and check that cookies expiration is set
            $res = $ua->get("http://127.0.0.1:$port/destroy_session");
            ok $res->is_success, "/destroy_session";
            $cookie = extract_cookie($res);
            ok $cookie, "session cookie set"
              or diag explain $cookie;
            is $cookie->{"dancer.session"}, $sid1, "correct cookie expired";
            ok $cookie->{expires} < time, "session cookie is expired";

            # shouldn't be sent session cookie after session destruction
            $res = $ua->get("http://127.0.0.1:$port/no_session_data");
            ok $res->is_success, "/no_session_data";
            $cookie = extract_cookie($res);
            ok !$cookie, "no cookie set"
              or diag explain $cookie;

            # set value into session again
            $res = $ua->get("http://127.0.0.1:$port/set_session/curly");
            ok $res->is_success, "/set_session/larry";
            $cookie = extract_cookie($res);
            ok $cookie, "session cookie set"
              or diag explain $cookie;
            my $sid2 = $cookie->{"dancer.session"};
            isnt $sid2, $sid1, "New session has different ID";

            # destroy and create a session in one request
            $res = $ua->get("http://127.0.0.1:$port/churn_session");
            ok $res->is_success, "/churn_session";
            $cookie = extract_cookie($res);
            ok $cookie, "session cookie set"
              or diag explain $cookie;
            my $sid3 = $cookie->{"dancer.session"};
            isnt $sid3, $sid2, "Changed session has different ID";

            # read value back
            $res = $ua->get("http://127.0.0.1:$port/read_session");
            ok $res->is_success, "/read_session";
            $cookie = extract_cookie($res);
            ok $cookie, "session cookie set"
              or diag explain $cookie;
            like $res->content, qr/name='damian'/, "session value looks good";

            File::Temp::cleanup();
        },
        server => sub {
            my $port = shift;

            use Dancer2;

            get '/no_session_data' => sub {
                return "session not modified";
            };

            get '/set_session/*' => sub {
                my ($name) = splat;
                session name => $name;
            };

            get '/read_session' => sub {
                my $name = session('name') || '';
                "name='$name'";
            };

            get '/destroy_session' => sub {
                my $name = session('name') || '';
                context->destroy_session;
                return "destroyed='$name'";
            };

            get '/churn_session' => sub {
                context->destroy_session;
                session name => 'damian';
                return "churned";
            };

            setting appdir => $tempdir;
            setting(engines =>
                  {session => {$engine => {session_dir => 't/sessions'}}});
            setting(session => $engine);

            set(show_errors  => 1,
                startup_info => 0,
                environment  => 'production',
                port         => $port
            );

            Dancer2->runner->server->port($port);
            start;
        },
    );
}
done_testing;