package Perinci::Tx::Manager;

use 5.010;
use strict;
use warnings;
use DBI;
use File::Flock;
use JSON;
use Log::Any '$log';
use Scalar::Util qw(blessed);
use Time::HiRes qw(time);

our $VERSION = '0.20'; # VERSION

my $json = JSON->new->allow_nonref;

# note: to avoid confusion, whenever we mention 'transaction' (or tx for short)
# in the code, we must always specify whether it is a sqlite tx (sqltx) or a
# Rinci tx (Rtx).

# note: no method should die(), they all should return error message/response
# instead. this is because we are called by Perinci::Access::InProcess and in
# turn it is called by Perinci::Access::HTTP::Server without extra eval().

# note: we have not dealt with sqlite's rowid wraparound. since it's a 64-bit
# integer, we're pretty safe. we also usually rely on ctime first for sorting.

# new() should return an error string if failed
sub new {
    my ($class, %opts) = @_;
    return "Please supply pa object" unless blessed $opts{pa};
    return "pa object must be an instance of Perinci::Access::InProcess"
        unless $opts{pa}->isa("Perinci::Access::InProcess");

    my $obj = bless \%opts, $class;
    if ($opts{data_dir}) {
        unless (-d $opts{data_dir}) {
            mkdir $opts{data_dir} or return "Can't mkdir $opts{data_dir}: $!";
        }
    } else {
        for ("$ENV{HOME}/.perinci", "$ENV{HOME}/.perinci/.tx") {
            unless (-d $_) {
                mkdir $_ or return "Can't mkdir $_: $!";
            }
        }
        $opts{data_dir} = "$ENV{HOME}/.perinci/.tx";
    }
    my $res = $obj->_init;
    return $res if $res;
    $obj;
}

sub _lock_db {
    my ($self, $shared) = @_;

    my $locked;
    my $secs = 0;
    for (1..5) {
        $locked = lock("$self->{_db_file}", $shared, "nonblocking");
        last if $locked;
        sleep    $_;
        $secs += $_;
    }
    return "Tx database is still locked by other process (probably recovery) ".
        "after $secs seconds, giving up" unless $locked;
    return;
}

sub _unlock_db {
    my ($self) = @_;

    unlock("$self->{_db_file}");
    return;
}

# return undef on success, or an error string on failure
sub _init {
    my ($self) = @_;
    my $data_dir = $self->{data_dir};
    $log->tracef("[txm] Initializing data dir %s ...", $data_dir);

    unless (-d "$self->{data_dir}/.trash") {
        mkdir "$self->{data_dir}/.trash"
            or return "Can't create .trash dir: $!";
    }
    unless (-d "$self->{data_dir}/.tmp") {
        mkdir "$self->{data_dir}/.tmp"
            or return "Can't create .tmp dir: $!";
    }

    $self->{_db_file} = "$data_dir/tx.db";

    (-d $data_dir)
        or return "Transaction data dir ($data_dir) doesn't exist or not a dir";
    my $dbh = DBI->connect("dbi:SQLite:dbname=$self->{_db_file}", undef, undef,
                           {RaiseError=>0});

    # init database

    $dbh->do(<<_) or return "Can't init tx db: create tx: ". $dbh->errstr;
CREATE TABLE IF NOT EXISTS tx (
    ser_id INTEGER PRIMARY KEY AUTOINCREMENT,
    str_id VARCHAR(200) NOT NULL,
    owner_id VARCHAR(64) NOT NULL,
    summary TEXT,
    status CHAR(1) NOT NULL, -- i, a, C, U, R, u, d, X, (e) [uppercase=final]
    ctime REAL NOT NULL,
    mtime REAL NOT NULL,
    last_call_id INTEGER, -- last processed call when rollback/undo/redo
    UNIQUE (str_id)
)
_

    # last_call_id is for the recovery process to avoid repeating all the
    # function calls when rollback failed in the middle. for example, tx1 has 3
    # calls c1, c2, c3 and is being rollbacked. txm executes c3, then c2, then
    # crashes before calling c1. since last_call_id is set to c2, then during
    # recovery, rollback continues at c1.

    $dbh->do(<<_) or return "Can't init tx db: create call: ". $dbh->errstr;
CREATE TABLE IF NOT EXISTS call (
    tx_ser_id INTEGER NOT NULL, -- refers tx(ser_id)
    id INTEGER PRIMARY KEY AUTOINCREMENT,
    ctime REAL NOT NULL,
    f TEXT NOT NULL,
    args TEXT NOT NULL
)
_
    $dbh->do(<<_) or return "Can't init tx db: create undo_step: ".$dbh->errstr;
CREATE TABLE IF NOT EXISTS undo_step (
    call_id INT NOT NULL, -- refers txcall(id)
    -- seq INTEGER NOT NULL, -- uses ROWID instead, sqlite-specific
    name TEXT, -- for named savepoint
    ctime REAL NOT NULL,
    data BLOB NOT NULL
)
_
    $dbh->do(<<_) or return "Can't init tx db: create redo_step: ".$dbh->errstr;
CREATE TABLE IF NOT EXISTS redo_step (
    call_id INT NOT NULL, -- refers txcall(id)
    -- seq INTEGER NOT NULL, -- uses ROWID instead, sqlite-specific
    ctime REAL NOT NULL,
    data BLOB NOT NULL
)
_

    $self->{_dbh} = $dbh;
    $log->tracef("[txm] Data dir initialization finished");
    $self->_recover;
}

sub get_trash_dir {
    my ($self) = @_;
    my $tx = $self->{_cur_tx};
    return [412, "No current transaction, won't create trash dir"] unless $tx;
    my $d = "$self->{data_dir}/.trash/$tx->{ser_id}";
    unless (-d $d) {
        mkdir $d or return [500, "Can't mkdir $d: $!"];
    }
    [200, "OK", $d];
}

sub get_tmp_dir {
    my ($self) = @_;
    my $tx = $self->{_cur_tx};
    return [412, "No current transaction, won't create tmp dir"] unless $tx;
    my $d = "$self->{data_dir}/.tmp/$tx->{ser_id}";
    unless (-d $d) {
        mkdir $d or return [500, "Can't mkdir $d: $!"];
    }
    [200, "OK", $d];
}

# return an enveloped response
sub _get_func_and_meta {
    my ($self, $func) = @_;

    my ($module, $leaf) = $func =~ /(.+)::(.+)/
        or return [400, "Not a valid fully qualified function name: $func"];
    my $module_p = $module; $module_p =~ s!::!/!g; $module_p .= ".pm";
    eval { require $module_p }
        or return [500, "Can't load module $module: $@"];
    my $res = $self->{pa}->_get_code_and_meta({
        -module=>$module, -leaf=>$leaf, -type=>'function'});
    $res;
}

sub _rollback_dbh {
    my $self = shift;
    $self->{_dbh}->rollback if $self->{_in_sqltx};
    $self->{_in_sqltx} = 0;
}

sub _commit_dbh {
    my $self = shift;
    return 1 unless $self->{_in_sqltx};
    my $res = $self->{_dbh}->commit;
    $self->{_in_sqltx} = 0;
    $res;
}

sub _get_undo_or_redo_steps {
    my ($self, $which, %args) = @_;
    my $call_id = $args{call_id} or return [400, "Please specify call_id"];
    my $dbh = $self->{_dbh};
    my $t = $which eq 'undo' ? 'undo_step' : 'redo_step';
    my $sth = $dbh->prepare(
        "SELECT data FROM $t WHERE call_id=? ORDER BY ROWID, ctime");
    $sth->execute($call_id) or return [500, "db: Can't select: ".$dbh->errstr];
    my @steps;
    my $i = 0;
    while (my @row = $sth->fetchrow_array) {
        $i++;
        my $step;
        eval { $step = $json->decode($row[0]) };
        return [500, "Step #$i is not deserializable from JSON: $@"] if $@;
        push @steps, $step;
    }
    [200, "OK", \@steps];
}

sub get_undo_steps {
    my $self = shift;
    $self->_get_undo_or_redo_steps('undo', @_);
}

sub get_redo_steps {
    my $self = shift;
    $self->_get_undo_or_redo_steps('redo', @_);
}

# return undef on success, or an error string on failure
sub _rollback_or_undo_or_redo {
    my ($self, $which) = @_;

    # rollback, undo, and redo share a fair amount of code, mainly looping
    # through function calls, so we combine them here.

    die "BUG: 'which' must be rollback/undo/redo"
        unless $which =~ /\A(rollback|undo|redo)\z/;

    # this prevent endless loop in rollback, since we call functions when doing
    # rollback, and functions might call $tx->rollback too upon failure.
    return if $self->{_in_rollback} && $which eq 'rollback';
    local $self->{_in_rollback} = 1 if $which eq 'rollback';

    my $tx = $self->{_cur_tx};
    unless ($tx) {
        $log->warnf("[txm] _$which() called w/o transaction, probably a bug");
        return;
    }
    $log->tracef("[txm] $which tx #%d (%s) ...", $tx->{ser_id}, $tx->{str_id});

    my $dbh = $self->{_dbh};

    $self->_rollback_dbh;
    # we're now in sqlite autocommit mode, we use this mode for the following
    # reasons: 1) after we set Rtx status to 'a' or 'u' or 'd', we need other
    # clients to see this, so they do not try to add steps to it. also after
    # that, each function call will involve record_call() and record_step() that
    # are all separate sqltx's so each call/step can be recorded permanently in
    # sqldb.

    my (@calls, $i_call, $call);
    my $os  = $tx->{status};
    my $ns  = $which eq 'rollback' ? 'a' : $which eq 'undo' ? 'u' : 'd';
    my $oss = $which eq 'rollback' ? "'i','u','d'" :
        $which eq 'undo' ? "'C'" : "'U'";
    eval {
        my $now = time();
        $dbh->do("UPDATE tx SET status='$ns', mtime=?, last_call_id=NULL ".
                     "WHERE ser_id=? AND status IN ($oss)",
                 {}, $now, $tx->{ser_id})
            or die "db: Can't update tx status $oss -> $ns: ".$dbh->errstr;

        # for safety, check once again if Rtx status is indeed updated
        my @r = $dbh->selectrow_array("SELECT status FROM tx WHERE ser_id=?",
                                      {}, $tx->{ser_id});
        die "Status incorrect ($r[0])" unless $r[0] eq $ns;

        my $lci = $tx->{last_call_id};
        my $rows = $dbh->selectall_arrayref(
            "SELECT id, f, args FROM call WHERE tx_ser_id=? ".
                ($lci ? "AND (id<>$lci AND ".
                     "ctime >= (SELECT ctime FROM call WHERE id=$lci))" : "").
                    "ORDER BY ctime, id",
            {}, $tx->{ser_id});
        for (@$rows) {
            push @calls, {id=>$_->[0], f=>$_->[1],
                          args=>$json->decode($_->[2])};
        }
        @calls = reverse(@calls) unless $which eq 'redo';
        #$log->tracef("[txm] [$which] Calls to perform: %s", \@calls);

        $i_call = 0;
        for (@calls) {
            $call = $_;
            $i_call++;
            $log->tracef("[txm] [$which] Performing call %d/%d: %s(%s) ...",
                         $i_call, scalar(@calls), $call->{f}, $call->{args});
            my $res = $self->_get_func_and_meta($call->{f});
            die "Can't get func: $res->[0] - $res->[1]" unless $res->[0] == 200;
            my ($func, $meta) = @{$res->[2]};
            # XXX check meta whether func supports undo + transactional?
            $res = $func->(
                %{$call->{args}},
                -undo_action=>($which eq 'redo' ? 'redo' : 'undo'),
                -tx_manager=>$self, -tx_call_id=>$call->{id},
                # the following special arg is just informative, so function
                # knows and can act more robust under rollback if it needs to
                -tx_action=>($which eq 'rollback' ? 'rollback' : undef),
            );
            $log->tracef("[txm] [$which] Call result: %s", $res);
            die "Call failed: $res->[0] - $res->[1]"
                unless $res->[0] == 200 || $res->[0] == 304;

            # update last_call so we don't have to repeat all calls when we
            # resume a failed rollback. error can be ignored here, i think.
            $dbh->do("UPDATE tx SET last_call_id=? WHERE ser_id=?", {},
                     $call->{id}, $tx->{ser_id}) if $which eq 'rollback';
        }
        if ($which eq 'undo' || $which eq 'redo') {
            my $t = $which eq 'undo' ? 'undo_step' : 'redo_step';
            $dbh->do("DELETE FROM $t WHERE call_id IN ".
                         "(SELECT id FROM call WHERE tx_ser_id=?)",
                     {}, $tx->{ser_id})
                or die "db: Can't empty $t: ".$dbh->errstr;
        }
        my $fs = $which eq 'rollback' ? 'R' : $which eq 'undo' ? 'U' : 'C';
        $dbh->do("UPDATE tx SET status='$fs', mtime=? WHERE ser_id=?", {},
                 $now, $tx->{ser_id})
            or die "db: Can't set tx status to $fs: ".$dbh->errstr;

    };
    my $eval_err = $@;
    if ($eval_err) {
        my $errmsg = join("",
                          ($i_call ? "Call #$i_call/".scalar(@calls).
                               " (func $call->{f}): " : ""),
                          $eval_err);
        if ($which eq 'rollback') {
            # if failed during rolling back, we don't know what else to do. we
            # set Rtx status to X (inconsistent) and ignore it.
            my $now = time();
            $dbh->do("UPDATE tx SET status='X', mtime=? ".
                         "WHERE ser_id=? AND status='a'",
                     {}, $now, $tx->{ser_id});
            return $errmsg;
        } else {
            my $rbres = $self->rollback;
            if ($rbres->[0] == 200) {
                return $errmsg." (rolled back)";
            } else {
                return $errmsg." (rollback failed: $rbres->[0] - $rbres->[1])";
            }
        }
    }
    return;
}

# return undef on success, or an error string on failure
sub _recover_or_cleanup {
    my ($self, $which) = @_;

    # TODO clean old tx's tmp_dir & trash_dir.

    $log->tracef("[txm] Performing $which ...");

    # there should be only one process running
    my $res = $self->_lock_db(undef);
    return $res if $res;

    # rolls back all transactions in a, u, d state

    # XXX when cleanup, also rolls back all i transactions that have been around
    # for too long
    my $dbh = $self->{_dbh};
    my $sth = $dbh->prepare(
        "SELECT * FROM tx WHERE status IN ('a', 'u', 'd') ".
            "ORDER BY ctime DESC",
    );
    $sth->execute or return "db: Can't select tx: ".$dbh->errstr;

    while (my $row = $sth->fetchrow_hashref) {
        $self->{_cur_tx} = $row;
        $self->_rollback;
    }

    $self->_unlock_db;

    # XXX when cleanup, discard all R Rtxs

    # XXX when cleanup, discard all C, U, X Rtxs that have been around too long

    $log->tracef("[txm] Finished $which");
    return;
}

sub _recover {
    my $self = shift;
    $self->_recover_or_cleanup('recover');
}

sub _cleanup {
    my $self = shift;
    $self->_recover_or_cleanup('cleanup');
}

sub __resp_tx_status {
    my ($r) = @_;
    my $s = $r->{status};
    my $ss =
        $s eq 'i' ? "still in-progress" :
            $s eq 'a' ? "aborted, further requests ignored until rolled back" :
                $s eq 'C' ? "already committed" :
                    $s eq 'R' ? "already rolled back" :
                        $s eq 'U' ? "already committed+undone" :
                            $s eq 'u' ? "undoing" :
                                $s eq 'd' ? "redoing" :
                                    $s eq 'X' ? "inconsistent" :
                                        "unknown (bug)";
    [480, "tx #$r->{ser_id}: Incorrect status, status is $s ($ss)"];
}

# all methods that work inside a transaction have some common code, e.g.
# database file locking, starting sqltx, checking Rtx status, etc. hence
# refactored into _wrap(). arguments:
#
# - label (string, just a label for logging)
#
# - args* (hashref, arguments to method)
#
# - cleanup (bool, default 0). whether to run cleanup first before code. this is
#   curently run by begin() only, to make up room by purging old transactions.
#
# - tx_status (str/array, if set then it means method requires Rtx to exist and
#   have a certain status(es)
#
# - code (coderef, main method code, will be passed args as hash)
#
# - hook_check_args (coderef, will be passed args as hash)
#
# - hook_after_commit (coderef, will be passed args as hash).
#
# - update_tx_mtime (bool, whether to update tx mtime on success of code,
#   default 0).
#
# wrap() will also put current Rtx record to $self->{_cur_tx}
sub _wrap {
    my ($self, %wargs) = @_;
    my $margs = $wargs{args}
        or return [500, "BUG: args not passed to _wrap()"];
    my @caller = caller(1);
    $log->tracef(
        "[txm] -> %s(%s) label=%s",
        $caller[3],
        { map {$_=>$margs->{$_}} grep {!/^-/ && !/^args$/} keys %$margs },
        $wargs{label},
    );

    my $res;

    $res = $self->_lock_db("shared");
    return [532, "Can't acquire lock: $res"] if $res;

    $self->{_now} = time();

    # initialize & check tx_id argument
    $margs->{tx_id} //= $self->{_tx_id};
    my $tx_id = $margs->{tx_id};
    $self->{_tx_id} = $tx_id;

    return [400, "Please specify tx_id"]
        unless defined($tx_id) && length($tx_id);
    return [400, "Invalid tx_id, please use 1-200 characters only"]
        unless length($tx_id) <= 200;

    my $dbh = $self->{_dbh};

    if ($wargs{cleanup}) {
        $res = $self->_cleanup;
        return [532, "Can't succesfully cleanup: $res"] if $res;
    }

    # we need to begin sqltx here so that client's actions like rollback() and
    # commit() are indeed atomic and do not interfere with other clients'.
    $dbh->begin_work or return [532, "db: Can't begin: ".$dbh->errstr];

    # DBI/DBD::SQLite currently does not support checking whether we are in an
    # active sqltx, except $dbh->{BegunWork} which is undocumented. we use our
    # own flag here.
    local $self->{_in_sqltx} = 1;

    my $cur_tx = $dbh->selectrow_hashref(
        "SELECT * FROM tx WHERE str_id=?", {}, $tx_id);
    $self->{_cur_tx} = $cur_tx;

    if ($wargs{hook_check_args}) {
        $res = $wargs{hook_check_args}->(%$margs);
        if ($res) {
            $self->_rollback;
            return $res;
        }
    }

    if ($wargs{tx_status}) {
        if (!$cur_tx) {
            $self->_rollback_dbh;
            return [484, "No such transaction"];
        }
        my $ok;
        # 'str' ~~ $aryref doesn't seem to work?
        if (ref($wargs{tx_status}) eq 'ARRAY') {
            $ok = $cur_tx->{status} ~~ @{$wargs{tx_status}};
        } else {
            $ok = $cur_tx->{status} ~~ $wargs{tx_status};
        }
        unless ($ok) {
            $self->_rollback_dbh;
            return __resp_tx_status($cur_tx);
        }
    }

    if ($wargs{code}) {
        $res = $wargs{code}->(%$margs, _tx=>$cur_tx);
        # on error, rollback sqlite tx and skip the rest
        if ($res->[0] >= 400) {
            $self->_rollback_dbh;
            $self->_rollback;
            return $res;
        }
    }

    if ($wargs{update_tx_mtime}) {
        $dbh->do("UPDATE tx SET mtime=? WHERE ser_id=?", {},
             $self->{_now}, $cur_tx->{ser_id});
    }

    $self->_commit_dbh or return [532, "db: Can't commit: ".$dbh->errstr];
    $self->{_in_sqltx} = 0;

    if ($wargs{hook_after_commit}) {
        my $res2 = $wargs{hook_after_tx}->(%$margs);
        return $res2 if $res2;
    }

    return $res;
}

# all methods that don't work inside a transaction have some common code, e.g.
# database file locking. arguments:
#
# - args* (hashref, arguments to method)
#
# - lock_db (bool, default false)
#
# - code* (coderef, main method code, will be passed args as hash)
#
sub _wrap2 {
    my ($self, %wargs) = @_;
    my $margs = $wargs{args}
        or return [500, "BUG: args not passed to _wrap()"];
    my @caller = caller(1);
    $log->tracef("[txm] -> %s(%s)", $caller[3],
                 { map {$_=>$margs->{$_}}
                       grep {!/^-/ && !/^args$/} keys %$margs });

    my $res;

    if ($wargs{lock_db}) {
        $res = $self->_lock_db("shared");
        return [532, "Can't acquire lock: $res"] if $res;
    }

    $res = $wargs{code}->(%$margs);

    if ($wargs{lock_db}) {
        $self->_unlock_db;
    }

    $res;
}

sub begin {
    my ($self, %args) = @_;
    $self->_wrap(
        args => \%args,
        cleanup => 1,
        code => sub {
            my $dbh = $self->{_dbh};
            my $r = $dbh->selectrow_hashref("SELECT * FROM tx WHERE str_id=?",
                                            {}, $args{tx_id});
            return [409, "Another transaction with that ID exists"] if $r;

            # XXX check for limits

            $dbh->do("INSERT INTO tx (str_id, owner_id, summary, status, ".
                         "ctime, mtime) VALUES (?,?,?,?, ?,?)", {},
                     $args{tx_id}, $args{client_token}//"", $args{summary}, "i",
                     $self->{_now}, $self->{_now},
                 ) or return [532, "db: Can't insert tx: ".$dbh->errstr];

            $self->{_tx_id} = $args{tx_id};
            [200, "OK"];
        },
    );
}

sub record_call {
    my ($self, %args) = @_;
    my @caller = caller(1);
    my ($f, $eargs);

    $self->_wrap(
        args => \%args,
        tx_status => ["i", "a"],
        hook_check_args => sub {
            #return [400, "Please specify f"]         unless $args{f};
            return [400, "Please specify args"]      unless $args{args};

            # status a is only allowed when we record steps during rollback
            my $cur_tx = $self->{_cur_tx};
            if ($cur_tx && $cur_tx->{status} eq 'a' && !$self->{_in_rollback}) {
                $self->_rollback_dbh;
                return __resp_tx_status($cur_tx);
            }

            my $f = $args{f} // $caller[3];
            # strip special arguments
            my %h;
            for (keys %{$args{args}}) {
                $h{$_} = $args{args}{$_} unless /^-/;
            }
            eval { $eargs = $json->encode(\%h) };
            return [400, "args data not serializable to JSON: $@"] if $@;

            return;
        },
        code => sub {
            my $dbh = $self->{_dbh};
            my $f = $args{f} // $caller[3];
            $dbh->do("INSERT INTO call (tx_ser_id, ctime, f, args) ".
                         "VALUES (?,?,?,?)", {},
                     $self->{_cur_tx}{ser_id}, $self->{_now}, $f, $eargs)
                or return [532, "db: Can't insert call: ".$dbh->errstr];
            return [200, "OK", $dbh->last_insert_id('','','','')];
        },
        update_tx_mtime => 1,
    );
}

sub record_undo_step {
    my $self = shift;
    $self->_record_step('undo', @_);
}

sub record_redo_step {
    my $self = shift;
    $self->_record_step('redo', @_);
}

sub _record_step {
    my ($self, $which, %args) = @_;
    die "BUG: which must be undo/redo" unless $which =~ /\A(un|re)do\z/;
    my $data;

    my $res = $self->_wrap(
        label => $which,
        args => \%args,
        hook_check_args => sub {
            $args{call_id} or return [400, "Please specify call_id"];
            $data = $args{data} or return [400, "Please specify data"];
            ref($data) eq 'ARRAY' or return [400, "data must be array"];
            eval { $data = $json->encode($data) };
            $@ and return [400, "step data not serializable to JSON: $@"];
            return;
        },
        tx_status => ["i", "a", "u", "d"],
        code => sub {
            my $dbh = $self->{_dbh};

            # status a is only allowed when we record steps during rollback
            my $cur_tx = $self->{_cur_tx};
            if ($cur_tx->{status} eq 'a' && !$self->{_in_rollback}) {
                $self->_rollback_dbh;
                return __resp_tx_status($cur_tx);
            }

            my $rc = $dbh->selectrow_hashref(
                "SELECT id FROM call WHERE id=?", {}, $args{call_id});
            return [400, "call_id does not exist in database"] unless $rc;

            $dbh->do("INSERT INTO ${which}_step (ctime, call_id, data) VALUES ".
                         "(?,?,?)", {}, $self->{_now}, $args{call_id}, $data)
                or return [532, "db: Can't insert step: ".$dbh->errstr];
            [200, "OK", $dbh->last_insert_id('','','','')];
        },
        update_tx_mtime => 1,
    );
    $res;
}

sub commit {
    my ($self, %args) = @_;
    $self->_wrap(
        args => \%args,
        tx_status => ["i", "a"],
        code => sub {
            my $dbh = $self->{_dbh};
            my $tx  = $self->{_cur_tx};
            if ($tx->{status} eq 'a') {
                my $res = $self->_rollback;
                return $res if $res;
                return [200, "Rolled back"];
            }
            $dbh->do("DELETE FROM redo_step WHERE call_id IN ".
                         "(SELECT id FROM call WHERE tx_ser_id=?)",
                     {}, $tx->{ser_id})
                or return [532, "db: Can't empty redo_step: ".$dbh->errstr];
            $dbh->do("UPDATE tx SET mtime=?, status=? WHERE ser_id=?",
                     {}, $self->{_now}, "C", $tx->{ser_id})
                or return [532, "db: Can't update tx status to committed: ".
                               $dbh->errstr];
            [200, "OK"];
        },
    );
}

sub _rollback {
    my ($self) = @_;
    $self->_rollback_or_undo_or_redo('rollback');
}

sub rollback {
    my ($self, %args) = @_;
    $self->_wrap(
        args => \%args,
        tx_status => ["i", "a"],
        code => sub {
            my $res = $self->_rollback;
            $res ? [532, $res] : [200, "OK"];
        },
    );
}

sub prepare {
    [501, "Not implemented"];
}

sub savepoint {
    [501, "Not yet implemented"];
}

sub release_savepoint {
    [501, "Not yet implemented"];
}

sub list {
    my ($self, %args) = @_;
    $self->_wrap2(
        args => \%args,
        code => sub {
            my $dbh = $self->{_dbh};
            my @wheres = ("1");
            my @params;
            if ($args{tx_id}) {
                push @wheres, "str_id=?";
                push @params, $args{tx_id};
            }
            if ($args{tx_status}) {
                push @wheres, "status=?";
                push @params, $args{tx_status};
            }
            my $sth = $dbh->prepare(
                "SELECT * FROM tx WHERE ".join(" AND ", @wheres).
                    " ORDER BY ctime, ser_id");
            $sth->execute(@params);
            my @res;
            while (my $row = $sth->fetchrow_hashref) {
                if ($args{detail}) {
                    push @res, {
                        tx_id         => $row->{str_id},
                        tx_status     => $row->{status},
                        tx_start_time => $row->{ctime},
                        tx_summary    => $row->{summary},
                        tx_end_time   => $row->{status} =~ /[CRUX]/ ?
                            $row->{mtime} : undef,
                    };
                } else {
                    push @res, $row->{str_id};
                }
            }
            [200, "OK", \@res];
        },
    );
}

sub undo {
    my ($self, %args) = @_;
    $self->_wrap(
        args => \%args,
        tx_status => ["C"],
        code => sub {
            my $res = $self->_rollback_or_undo_or_redo('undo');
            $res ? [532, $res] : [200, "OK"];
        },
    );
}

sub redo {
    my ($self, %args) = @_;
    $self->_wrap(
        args => \%args,
        tx_status => ["U"],
        code => sub {
            my $res = $self->_rollback_or_undo_or_redo('redo');
            $res ? [532, $res] : [200, "OK"];
        },
    );
}

sub _discard {
    my ($self, $which, %args) = @_;
    my $wmeth = $which eq 'one' ? '_wrap' : '_wrap2';
    $self->$wmeth(
        label => $which,
        args => \%args,
        tx_status => $which eq 'one' ? ['C','U','X'] : undef,
        code => sub {
            my $dbh = $self->{_dbh};
            my $sth;
            if ($which eq 'one') {
                $sth = $dbh->prepare("SELECT ser_id FROM tx WHERE str_id=?");
                $sth->execute($self->{_cur_tx}{str_id});
            } else {
                $sth = $dbh->prepare(
                    "SELECT ser_id FROM tx WHERE status IN ('C','U','X')");
                $sth->execute;
            }
            my @txs;
            while (my @row = $sth->fetchrow_array) {
                push @txs, $row[0];
            }
            if (@txs) {
                $dbh->do("DELETE FROM tx WHERE ser_id IN (".join(",", @txs).")")
                    or return [532, "db: Can't delete tx: ".$dbh->errstr];
                $log->infof("[txm] discard tx: %s", \@txs);
            }
            [200, "OK"];
        },
    );
}

sub discard {
    my $self = shift;
    $self->_discard('one', @_);
}

sub discard_all {
    my $self = shift;
    $self->_discard('all', @_);
}

1;
# ABSTRACT: Transaction manager


__END__
=pod

=head1 NAME

Perinci::Tx::Manager - Transaction manager

=head1 VERSION

version 0.20

=head1 SYNOPSIS

 # used by Perinci::Access::InProcess

=head1 DESCRIPTION

This class implements transaction and undo manager (TM), as specified by
L<Rinci::function::Transaction> and L<Riap::Transaction>. It is meant to be
instantiated by L<Perinci::Access::InProcess>, but will also be passed to
transactional functions to save undo/redo data.

It uses SQLite database to store transaction list and undo/redo data as well as
transaction data directory to provide trash_dir/tmp_dir for functions that
require it.

=head1 METHODS

=head2 new(%args) => OBJ

Create new object. Arguments:

=over 4

=item * pa => OBJ

Perinci::Access::InProcess object. This is required by Perinci::Tx::Manager to
load/get functions when it wants to perform undo/redo/recovery.
Perinci::Access::InProcess conveniently require() the Perl modules and wraps the
functions.

=item * data_dir => STR (default C<~/.perinci/.tx>)

=item * max_txs => INT (default 1000)

Limit maximum number of transactions maintained by the TM, including all rolled
back and committed transactions, since they are still recorded in the database.
The default is 1000.

Not yet implemented.

After this limit is reached, cleanup will be performed to delete rolled back
transactions, and after that committed transactions.

=item * max_open_txs => INT (default 100)

Limit maximum number of open (in progress, aborted, prepared) transactions. This
exclude resolved transactions (rolled back and committed). The default is no
limit.

Not yet implemented.

After this limit is reached, starting a new transaction will fail.

=item * max_committed_txs => INT (default 100)

Limit maximum number of committed transactions that is recorded by the database.
This is equal to the number of undo steps that are remembered.

After this limit is reached, cleanup will automatically be performed so that
the oldest committed transactions are purged.

Not yet implemented.

=item * max_open_age => INT

Limit the maximum age of open transactions (in seconds). If this limit is
reached, in progress transactions will automatically be purged because it times
out.

Not yet implemented.

=item * max_committed_age => INT

Limit the maximum age of committed transactions (in seconds). If this limit is
reached, the old transactions will start to be purged.

Not yet implemented.

=back

=head2 $tx->_tx_id($tx_id)

Set tx_id. This is just a convenience so that methods that require tx_id will
get the default value from here if tx_id not specified in arguments.

=head2 $tx->begin(%args) => RESP

Start a new transaction.

Arguments: tx_id (str, required, unless already supplied via _tx_id()), twopc
(bool, optional, currently must be false since distributed transaction is not
yet supported), summary (optional).

TM will create an entry for this transaction in its database.

=head2 $tx->record_call(%args) => RESP

Record a function call. This method needs to be called before function does any
step.

Arguments: tx_id, f (optional, function name, will be retrieved from caller(1)
if not specified, assuming the call is from the function itself), args
(required, function arguments).

TM will create an entry for this call in its database.

Return call ID in enveloped response.

=head2 $tx->record_undo_step(%args) => RESP

Record an undo step. This method needs to be called before performing a step.

Arguments: tx_id, call_id, data (an array).

=head2 $tx->record_redo_step(%args) => RESP

Record a redo step. This method needs to be called before performing an undo
step.

Arguments: tx_id, call_id, data (an array).

=head2 $tx->get_undo_steps(%args) => RESP

Will return (in enveloped response) an array of undo steps, e.g. [200, "OK",
[["step1"], ["step2", "arg"], ...]] for the particular call.

Arguments: tx_id, call_id.

=head2 $tx->get_redo_steps(%args) => RESP

Will return (in enveloped response) an array of redo steps, e.g. [200, "OK",
[["step2"], ["step1"], ...]] for the particular call.

Arguments: tx_id, call_id.

=head2 $tx->commit(%args) => RESP

Arguments: tx_id

=head2 $tx->rollback(%args) => RESP

Arguments: tx_id, sp (optional, savepoint name to rollback to a specific
savepoint only).

Currently rolling back to a savepoint is not implemented.

=head2 $tx->prepare(%args) => RESP

Currently will return 501 (not implemented). This TM does not support
distributed transaction.

Arguments: tx_id

=head2 $tx->savepoint(%args) => RESP

Arguments: tx_id, sp (savepoint name).

Currently not implemented.

=head2 $tx->release_savepoint(%args) => RESP

Arguments: tx_id, sp (savepoint name).

Currently not implemented.

=head2 $tx->undo(%args) => RESP

Arguments: tx_id

=head2 $tx->redo(%args) => RESP

Arguments: tx_id

=head2 $tx->list(%args) => RESP

List transactions. Return an array of results sorted by creation date (in
ascending order).

Arguments: B<detail> (bool, default 0, whether to return transaction records
instead of just a list of transaction ID's).

=head2 $tx->discard(%args) => RESP

Discard (forget) a committed transaction. The transaction will no longer be
undoable.

Arguments: tx_id

=head2 $tx->discard_all(%args) => RESP

Discard (forget) all committed transactions.

=head1 SEE ALSO

L<Riap::Transaction>

L<Perinci::Access::InProcess>

L<Rinci::function::Undo>

L<Rinci::function::Transaction>

=head1 AUTHOR

Steven Haryanto <stevenharyanto@gmail.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 by Steven Haryanto.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

