#!perl

use 5.010;
use strict;
use warnings;
use FindBin '$Bin';
use lib "$Bin/lib";

use Test::More 0.96;

use File::chdir;
use File::Temp qw(tempdir);
use Perinci::Access::Schemeless;
use Perinci::Tx::Manager;
use Scalar::Util qw(blessed);

test_request(
    name => 'must be activated with use_tx',
    req => [begin_tx=>"/", {tx_id=>"tx1"}],
    status => 501,
);

my $tm;
my $tmp_dir = tempdir(CLEANUP=>1);
$CWD = $tmp_dir;
my $tx_dir  = "$tmp_dir/.tx";
diag "tx dir is $tx_dir";
my $pa_cached = Perinci::Access::Schemeless->new(
    use_tx=>1,
    custom_tx_manager => sub {
        my $self = shift;
        $tm //= Perinci::Tx::Manager->new(
            data_dir => $tx_dir, pa => $self);
        die $tm unless blessed($tm);
        $tm;
    });

subtest 'request to unknown tx = fail' => sub {
    test_request(
        req => [call=>"/TestTx/setval",
                {tx_id=>"unknown1",
                 args=>{name=>"x", value=>1}}],
        status => 484,
    );
};

subtest 'successful transaction' => sub {
    test_request(
        req => [begin_tx=>"/", {tx_id=>"s1"}],
        status => 200,
        posttest => sub {
            my $tres = $tm->list(detail=>1);
            is($tres->[0], 200, "txm->list() success");
            is(scalar(@{$tres->[2]}), 1, "There is 1 transaction");
            is($tres->[2][0]{tx_status}, "i", "Transaction status is i");
        },
    );
    test_request(
        req => [call=>"/TestTx/setval",
                {tx_id=>"s1",
                 args=>{name=>"s1_a", value=>1}}],
        status => 200,
        posttest => sub {
            my ($res) = @_;
            my $tres = $tm->list(detail=>1, tx_id=>"s1");
            is($tres->[2][0]{tx_status}, "i", "Transaction status is i");
        },
    );
    test_request(
        req => [call=>"/TestTx/setval",
                {tx_id=>"s1",
                 args=>{name=>"s1_b", value=>2}}],
        status => 200,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"s1");
            is($tres->[2][0]{tx_status}, "i", "Transaction status is i");
        },
    );
    test_request(
        req => [commit_tx=>"/", {tx_id=>"s1"}],
        status => 200,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"s1");
            is($tres->[2][0]{tx_status}, "C", "Transaction status is C");

            is($TestTx::vals{s1_a}, 1, "final state of s1_a = 1");
            is($TestTx::vals{s1_b}, 2, "final state of s1_b = 2");
        },
    );
};
# txs: s1(C)

subtest 'cannot begin transaction with the same name as existing (C)' => sub {
    test_request(
        req => [begin_tx=>"/", {tx_id=>"s1"}],
        status => 409,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"s1");
            is($tres->[2][0]{tx_status}, "C", "Transaction status is C");
        },
    );
};

subtest 'cannot begin transaction with the same name as existing (i)' => sub {
    test_request(
        req => [begin_tx=>"/" , {tx_id=>"s1b1"}],
        status => 200,
    );
    test_request(
        req => [begin_tx=>"/" , {tx_id=>"s1b1"}],
        status => 409,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"s1b1");
            is($tres->[2][0]{tx_status}, "i", "Transaction status is i");
        },
    );
    test_request(
        req => [rollback_tx=>"/" , {tx_id=>"s1b1"}],
        status => 200,
    );
    test_request(
        req => [discard_tx=>"/" , {tx_id=>"s1b1"}],
        status => 200,
    );
};

subtest 'failed invocation = rolls back' => sub {
    test_request(
        req => [begin_tx=>"/", {tx_id=>"f1"}],
        status => 200,
    );
    test_request(
        req => [call=>"/TestTx/setval",
                {tx_id=>"f1", args=>{}}],
        status => 400,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"f1");
            is($tres->[2][0]{tx_status}, "R", "Transaction status is R");
        },
    );
};
# txs: s1(C), f1(R)[cleaned]

subtest 'invoking unqualified function = rolls back' => sub {
    test_request(
        req => [begin_tx=>"/", {tx_id=>"f2"}],
        status => 200,
    );
    test_request(
        req => [call=>"/TestTx/delay",
                {tx_id=>"f2", args=>{n=>0}}],
        status => 532, #412,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"f2");
            is($tres->[2][0]{tx_status}, "R", "Transaction status is R");
        },
    );
};
# txs: s1(C), f2(R)[cleaned]

subtest 'argument not serializable to JSON = rolls back' => sub {
    test_request(
        req => [begin_tx=>"/", {tx_id=>"f3"}],
        status => 200,
    );
    test_request(
        req => [call=>"/TestTx/setval",
                {tx_id=>"f3", args=>{name=>"a", value=>qr//}}],
        status => 532,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"f3");
            is($tres->[2][0]{tx_status}, "R", "Transaction status is R");
        },
    );
};
# txs: s1(C), f3(R)[cleaned]

# currently, due to the way Perinci::Access::Schemeless works, request to
# unknown module never reaches action_call(), so we can't rollback
#
#subtest 'request to unknown function = rolls back' => sub {
#    test_request(
#        req => [begin_tx=>"/", {tx_id=>"f4"}],
#        status => 200,
#    );
#    test_request(
#        req => [call=>"/Foo/bar",
#                {tx_id=>"f4", args=>{}}],
#        status => 500,
#        posttest => sub {
#            my $tres = $tm->list(detail=>1, tx_id=>"f4");
#            is($tres->[2][0]{tx_status}, "R", "Transaction status is R");
#        },
#    );
#};
## txs: s1(C), f4(R)[cleaned]

subtest 'rollback' => sub {
    test_request(
        req => [begin_tx=>"/", {tx_id=>"r1"}],
        status => 200,
    );
    test_request(
        req => [call=>"/TestTx/setval",
                {tx_id=>"r1",
                 args=>{name=>"r1_a", value=>1}}],
        status => 200,
    );
    test_request(
        req => [call=>"/TestTx/setval",
                {tx_id=>"r1",
                 args=>{name=>"r1_b", value=>2}}],
        status => 200,
    );
    test_request(
        req => [call=>"/TestTx/setval",
                {args=>{name=>"r1_c", value=>3, -tx_action=>'fix_state'}}],
        status => 200,
    );
    test_request(
        req => [rollback_tx=>"/", {tx_id=>"r1"}],
        status => 200,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"r1");
            is($tres->[2][0]{tx_status}, "R", "Transaction status is R");

            ok(!$TestTx::vals{r1_a}, "final state of r1_a = unset");
            ok(!$TestTx::vals{r1_b}, "final state of r1_b = unset");

            # call without tx_id is outside of tx
            is($TestTx::vals{r1_c}, 3,
               "final state of r1_c = 3 (outside tx)");
        },
    );
};
# txs: s1(C), r1(R)[cleaned]

subtest 'list_txs' => sub {
    test_request(
        name => 'detail=0',
        req => [list_txs=>"/", {}],
        status => 200,
        posttest => sub {
            my ($res) = @_;
            is(scalar(@{$res->[2]}), 2, "num");
            ok(!ref($res->[2][0]), "no detail");
        },
    );
    test_request(
        name => 'tx_id',
        req => [list_txs=>"/", {tx_id=>'s1'}],
        status => 200,
        posttest => sub {
            my ($res) = @_;
            is(scalar(@{$res->[2]}), 1, "num");
        },
    );
    test_request(
        name => 'tx_status',
        req => [list_txs=>"/", {tx_status=>'R'}],
        status => 200,
        posttest => sub {
            my ($res) = @_;
            is(scalar(@{$res->[2]}), 1, "num");
        },
    );
};

subtest 'cannot rollback transactions with status C' => sub {
    test_request(
        req => [rollback_tx=>"/", {tx_id=>"s1"}],
        status => 480,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"s1");
            is($tres->[2][0]{tx_status}, "C", "Transaction status is C");

            is($TestTx::vals{s1_a}, 1, "final state of s1_a = 1");
            is($TestTx::vals{s1_b}, 2, "final state of s1_a = 2");
        },
    );
};
subtest 'cannot rollback transactions with status R' => sub {
    test_request(
        req => [rollback_tx=>"/", {tx_id=>"r1"}],
        status => 480,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"r1");
            is($tres->[2][0]{tx_status}, "R", "Transaction status is R");

            ok(!$TestTx::vals{r1_a}, "final state of r1_a = unset");
            ok(!$TestTx::vals{r1_b}, "final state of r1_a = unset");
        },
    );
};

# TODO cannot rollback transactions with status U, X

subtest 'undo' => sub {
    test_request(
        req => [undo=>"/", {tx_id=>"s1"}],
        status => 200,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"s1");
            is($tres->[2][0]{tx_status}, "U", "Transaction status is U");

            ok(!$TestTx::vals{s1_a}, "final state of s1_a = unset");
            ok(!$TestTx::vals{s1_b}, "final state of s1_a = unset");
        },
    );
};
# txs: s1(U)

# TODO cannot undo transactions in states i, U, X, R, ...

subtest 'redo' => sub {
    test_request(
        req => [redo=>"/", {tx_id=>"s1"}],
        status => 200,
        posttest => sub {
            my $tres = $tm->list(detail=>1, tx_id=>"s1");
            is($tres->[2][0]{tx_status}, "C", "Transaction status is C");

            is($TestTx::vals{s1_a}, 1, "final state of s1_a = 1");
            is($TestTx::vals{s1_b}, 2, "final state of s1_a = 2");
        },
    );
};
# txs: s1(C)

# TODO cannot redo transactions in states i, C, X, R, ...

subtest 'discard_tx' => sub {
    test_request(
        req => [discard_tx=>"/", {tx_id=>"s1"}],
        status => 200,
        posttest => sub {
            my $tres = $tm->list(tx_status=>"C");
            is(scalar(@{$tres->[2]}), 0, "num C = 0");

            # discarding does not effect transaction result
            is($TestTx::vals{s1_a}, 1, "final state of s1_a = 1");
            is($TestTx::vals{s1_b}, 2, "final state of s1_a = 2");
        },
    );
};
# txs:

# TODO test cannot discard transactions in states i, ...

subtest 'discard_all_txs' => sub {
    # commit some txs first
    test_request(req => [begin_tx=>"/" , {tx_id=>"sd1"}], status => 200);
    test_request(req => [commit_tx=>"/", {tx_id=>"sd1"}], status => 200);
    test_request(req => [begin_tx=>"/" , {tx_id=>"sd2"}], status => 200);
    test_request(req => [commit_tx=>"/", {tx_id=>"sd2"}], status => 200);
    test_request(req => [undo=>"/"     , {tx_id=>"sd2"}], status => 200);
    test_request(req => [begin_tx=>"/" , {tx_id=>"sd3"}], status => 200);
    test_request(
        req => [commit_tx=>"/", {tx_id=>"sd3"}], status => 200,
        posttest => sub {
            my $tres = $tm->list(tx_status=>"C");
            is(scalar(@{$tres->[2]}), 2, "num C = 2");
            $tres = $tm->list(tx_status=>"U");
            is(scalar(@{$tres->[2]}), 1, "num U = 1");
        }
    );
    # TODO test discard transactions in state X
    test_request(
        req => [discard_all_txs=>"/"],
        status => 200,
        posttest => sub {
            my $tres = $tm->list(tx_status=>"C");
            is(scalar(@{$tres->[2]}), 0, "num C = 0");
            $tres = $tm->list(tx_status=>"U");
            is(scalar(@{$tres->[2]}), 0, "num U = 0");
        },
    );
};
# txs:

# TODO in-progress transaction cannot be discarded

# TODO test two transactions in parallel (one client)

DONE_TESTING:
done_testing();
if (Test::More->builder->is_passing) {
    #diag "all tests successful, deleting test data dir";
    $CWD = "/" unless $ENV{NO_CLEANUP};
} else {
    diag "there are failing tests, not deleting tx dir";
}

sub test_request {
    my %args = @_;
    my $req = $args{req};
    my $test_name = ($args{name} // "") . " (req: $req->[0] $req->[1])";
    subtest $test_name => sub {
        my $pa;
        if ($args{object_opts}) {
            $pa = Perinci::Access::Schemeless->new(%{$args{object_opts}});
        } else {
            unless ($pa_cached) {
                $pa_cached = Perinci::Access::Schemeless->new;
            }
            $pa = $pa_cached;
        }
        my $res = $pa->request(@$req);
        if ($args{status}) {
            is($res->[0], $args{status}, "status")
                or diag explain $res;
        }
        if (exists $args{result}) {
            is_deeply($res->[2], $args{result}, "result")
                or diag explain $res;
        }
        if ($args{posttest}) {
            $args{posttest}($res);
        }
        done_testing();
    };
}