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;

            # no 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, "no cookie set"
              or diag explain $cookie;

            # 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;
            my $sid1 = $cookie->{"dancer.session"};

            # 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;