treasuredb/trsr

#!/usr/bin/env perl
use strict;
use utf8;

my ($db, %OPTS, $ACCOUNT, %targets);

package Commands {
use Text::Wrap qw(wrap);
use Carp qw(croak);
use Scalar::Util qw(openhandle);

use open qw/:std :encoding(utf8)/;

sub import {
    $db = $_[1];
    set_txn_mode(undef, $_[2] // "each");
}

sub cond_txn_all (&);
sub cond_txn_each (&);
sub set_txn_mode {
    my (undef, $mode) = @_;

    my $with_txn = sub (&) { $db->storage->txn_do(shift) };
    my $no_txn = sub (&) { goto &{$_[0]} };

    no warnings 'redefine';
    if ( $mode eq "all" ) {
        *cond_txn_all = $with_txn;
        *cond_txn_each = $no_txn;
    }
    elsif ( $mode eq "each" ) {
        *cond_txn_all = $no_txn;
        *cond_txn_each = $with_txn;
    }
    else {
        croak "Unsupported txn_mode $mode";
    }
}

sub single_charge { # charge interactively
    my $accounts = $db->resultset("Account");

    _require_value();
    _require_purpose();
    _provide_date();

    my $billId = delete $OPTS{'bill-id'}
        and _require_target();

    my $charger = sub {
        my ($account, $billId) = @_;
        my $what = $billId ? 'add_to_debits' : 'add_to_credits';
        return $account->$what({
            $billId ? (
                billId => sprintf($billId, $account->ID),
                targetCredit => delete( $OPTS{target} ),
            ) : (),
            map { $_ => $OPTS{$_} } qw(value purpose date),
        });
    };

    if ( $ACCOUNT ) {
        my $account = $accounts->find({ ID => $ACCOUNT });
        my ($record, $transf_count);
        cond_txn_each { 
            $record = $charger->($account, $billId);
            if ( !$billId and my $t = $OPTS{target} ) {
                $transf_count = $db->make_transfers( $record->ID => $t );
            }
        };
        printf("Created %s, transferred %d of %d.\n",
            $billId // $record->credId, $transf_count, $record->value
        );
    }

    elsif ( $billId =~ s{ @ (\{)? ((?(1)\S+|\w+)) (?(1)\}) }{ %s }xms ) {
        # ^^ regex to consider list of real or pseudonymized account IDs
        # e.g. @Member | @{one,another,...} | @{M{xyz},M{mno}} 
        $accounts = $accounts->search({
            $1 ? (ID => { -in => [ split /,/, $2 ] }) : ( type => $2 )
        });
        cond_txn_all {
            while ( my $account = $accounts->next ) {
                cond_txn_each { $charger->( $account, $billId ); }
            }
        };
    }

    else {
        croak "You haven't specified an account to charge";
    }

}

sub _require_value {
    until ( $OPTS{value} && $OPTS{value} =~ m{^\d+(\.\d\d)?$} ) {
        print "Charge value in cent (or use decimal point): ";
        chomp( $OPTS{value} = <STDIN> );
    }
    $_ = integer_money_value($_) for $OPTS{value};
}

sub _require_purpose {
    until ( $OPTS{purpose} ) {
        print "Purpose: ";
        chomp( $OPTS{purpose} = <STDIN> );
    }
}

sub _provide_date {
    my ($YEAR, $MONTH, $DAY) = (localtime)[3,4,5];
    $YEAR += 1900; $MONTH++;
    until ( $OPTS{date} && $OPTS{date} =~ m{\d{4}-?\d\d-?\d\d} ) {

        printf "Full date [YYYY-MM-DD] or year [%d]: ", $YEAR;
        chomp( my $year = <STDIN> );
        if ( !length($year) ) {}
        elsif ( $year =~ m{^(\d{4})-(\d\d)-(\d\d)$} ) {
            ($YEAR, $MONTH, $DAY) = ($1, $2, $3);
            goto ASSIGN;
        }
        elsif ( $year =~ m{^(\d\d)?\d\d$} && $year > 0 ) {
            substr $year, 0, 0, 20 if !$1;
            if ( $year ne $YEAR ) {
                $YEAR = $year;
                $_ = '' for $MONTH, $DAY;
            }
        }
        else { redo; }
        
        printf "Month [%d]: ", $MONTH;
        chomp( my $month = <STDIN> );
        if ( !length( $month ) && $MONTH ) {}
        elsif ( $month !~ m{\D} && $month > 0 && $month < 13 ) {
            if ( $month != $MONTH ) {
                $MONTH = $month;
                $DAY = '';
            }
        }
        else { redo; }

        printf "Day [%d]: ", $DAY;
        chomp( my $day = <STDIN> );
        if ( !length( $day ) ) {}
        elsif ( $day !~ m{\D} && $day > 0 && $month < 31 ) {
            $DAY = $day;
        }
        else { redo; }

        ASSIGN:
        $OPTS{date} = sprintf "%4d-%02d-%02d", $YEAR, $MONTH, $DAY;

    }
}

sub _require_target {
    my $t;
    until ( $t = $OPTS{target} and $t =~ m{^\d+$} ) {
        unless ( $t ) {
            print "Target credit id: ";
            chomp( my $t = <STDIN> );
        }
        if ( $t =~ m{ \A \? (\w+) \z } ) {
            $OPTS{target} = select_target_credit_from($t);
        }
    }
}

sub charge_account {
    goto &single_charge if %OPTS;

    print "Enter records ...\n" if -t STDIN;

    local *ARGV = (
        openhandle($_[0])
        // croak "charge_account() expects open file handle to read from"
    ) if my $abort_on_exception = exists $_[0];

    # Possible line formats:
    # -------------------------------------------------------
    #
    # Date Account Var Amount Purpose     :: Credit (Payment or target)
    #              ^^^ Field may be empty or '+', yet not omitted
    # Date Account Amount TCr ID: Purpose :: Bill
    #                     ^^^ Field may be empty, yet not omitted
    #
    # Please note: Omit Account if it is specified on commandline.
    #

    cond_txn_all {

        while ( defined( my $line = <ARGV> ) ) {
    
            _strip_comment_from($line) // next;
    
            my ($sep) = $line =~ m{([,; \t|])};

            my @columns
              = split /[$sep][ ]*/, $line,
                defined($ACCOUNT) ? 4 : 5;
    
            splice @columns, 1, 0, $ACCOUNT // ();

            # Strip quotes from all but ultimate purpose
            for ( @columns[ 0 .. 3 ] ) {
                m{\A(["'])}xms && m{$1\z}xms or next;
                substr $_,  0, 1, '';
                substr $_, -1, 1, '';
            }
            my ($record, $transf_count)
                = eval { cond_txn_each { _inner_charge(@columns) } };

            if ( !defined $record ) {
                if ( $@ ) {
                    die $@ if $abort_on_exception;
                    warn $@;
                    next;
                }
                else { die '_inner_charge() returned nothing'; }
            };

            printf("Created %s, transferred %d of %d.\n",
                eval { $record->billId } // $record->credId,
                $transf_count, $record->value
            );
        }

    }
}

sub _inner_charge {
    my ($date, $account, $debit, $credit, $purpose) = @_;

    $account = $db->resultset("Account")->find($account)
        // croak "There is no account with that name: $account";

    chomp $credit if !defined $purpose;
        
    { # In order to slurp any consecutive lines take two cases into account:
      #   1) Purpose has not begun next from value on initial line ->
      #      Grab every line before the next empty one (must have no length).
      #      Consider any quotes to be literal.
      #   2) Grab everything until closing quote is recognized.
      #      This is the case when the quote is the same as the opening one,
      #      it in not doubled and before a space or the end of line.

        my ($quot, $end, $has_more, $line);

        $DB::single = 1;

        if ( defined $purpose ) {
            $has_more = $purpose !~ s{ \A (?<quot> ["'] ) }{}xms
                     && $purpose =~ m{ : \s* \z }xms;
        }
        else {
            $has_more = 1;
            ($purpose = <ARGV>) =~ s{^\s+}{};
        }

        while (1) { # Single iteration, either early closed or redone

            $has_more
                or # we are inside region wrapped by identical quotes:
                   ($quot = $+{quot}) .. ( $end = $purpose =~ s{
                       \G             # from position of last iteration
                       (?<![$quot\\]) # must not be preseded by escape or
                       ($quot)        # same quote
                       (?=\s|\z)      # before space or end of line
                     }{}goxms
                   )
                or last # because there are no consecutive lines.
                ;

            last if (!$+{quot} && $end)        # we reach closing quote
                 || !defined($line = <ARGV>)   # there is no next line
                 || ($has_more && $line eq $/) # empty line             
                 ;

            $line =~ s{^\s+}{};
            $line =~ s{$quot{2}}{$quot}g if $quot; # merge consecutive quotes
            $purpose .= $line;

        }

        chomp $purpose;
        _strip_comment_from($purpose);

    }

    my ($record, @transfer, $category);

    if ( $purpose =~ s{ \s* -C\[ ([^\r\t\n\]]+) \] \z }{}xms ) {
        $category = $db->resultset("Category")->search({
            $1 =~ /^\d+$/ ? (ID => $1) : (label => { -like => "$1%" })
        })->single->ID;
    }

    if ( $debit =~ /\b\d/ ) {

        my $tgt = $credit;
        my $billId = $purpose =~ s{ \A ([[:graph:]]+?) : \s* }{}xms
                   ? $1
                   : croak qq{Missing ID in debit purpose: $purpose}
                   ;

        if ( $purpose =~ s{ (?: \t | \s* << \s* ) (.+?) \r? \n? \z }{}xms ) {
            push @transfer, [
               map { /\D/ ? $targets{ $_ } : $_ } split /,\s*/, $1
            ] => $billId;
        }
            
        if ( my ($var, $op, $assigned)
                 = $tgt =~ m{ \A ([A-Za-z]\w+) ([?=]) (\w+) \z }xms
           ) {

            if ( defined( my $c = $targets{$var} ) ) {
                croak "$var already assigned to $c";
            }

            if ( $op eq q{=} ) {
                $tgt = $targets{ $var } = $assigned;
            }
            else {
                $tgt = select_target_credit_from($assigned, $var);
            }

        }
        elsif ( $tgt =~ /^[a-z]/i ) {
            $tgt = $targets{ $tgt }
                // croak "Target credit not assigned: $tgt!\n";
        }
        else { $tgt = undef; }

        $record = $account->add_to_debits({
            billId => $billId,
            date => $date,
            purpose => $purpose,
            value => integer_money_value($debit),
            targetCredit => $tgt,
            category => $category
        });

    }

    elsif ( $credit =~ /\b\d/ ) {

        my $tgt = $purpose =~ s{ \s* >> \s* (.+) \r? \n? \z }{}xms && $1;

        my $c = $account->add_to_credits({
            date => $date,
            account => $account,
            purpose => $purpose,
            value => integer_money_value($credit),
            category => $category
        });

        if ( $debit =~ /^[a-z]/i ) { $targets{ $debit } = $c->credId; }
        elsif ( length $debit && $debit ne q{+} ) {
            croak "Invalid field input: $debit neither number nor name";
        }

        push @transfer, $c->credId => $tgt if $tgt;

        $record = $c;
    }

    else {
        croak "Cannot be parsed: $debit $credit\n";
    }

    return $record, @transfer ? $db->make_transfers(@transfer) : 0;

}

sub _strip_comment_from {
    my $comment;
    $comment .= $1 while $_[0] =~ s{ \s+ (?<!\\) \# (.*) $ }{}gxm;
    $comment =~ s{\\#}{#}gxms;
    return( $comment or length($_[0]) ? q{} : undef );
}
 
sub integer_money_value {

    my $val = shift;

    # Strip currency signs and space.
    $val =~ s{ \A [^0-9]+ }{}xms;
    $val =~ s{ [^0-9]+ \z }{}xms;

    # Strip cent to finally add to the integer
    my $cent = $val =~ s{ [,.] ([0-9]{2})? \z }{}xms ? $1 || 0 : undef;

    # Strip number formatting separators
    $val =~ s{ (?<=[0-9]) [ _.,'’] (?=[0-9]) }{}gxms;

    die "Not a positive money value (cent): $val" if $val =~ /[^0-9]/;

    ($val *= 100) += $cent if defined $cent;
    return $val;
}

sub select_target_credit_from {
    my ($account, $var) = @_;

    croak "Interactive target credit selection is not possible"
        if !( -t STDIN );

    print "Please select target credit to reference by $var:\n",
          "-------------------------------------------------\n";

    $account = $db->resultset("Account")->find($account);
    my $credits = $account->credits->search({}, {
        join => 'income',
        group_by => ['income.targetCredit'],
        having => \[ 'ifnull(sum(income.paid),0) = me.value' ],
    });

    croak $account->ID
        . " has no credits to receive settlements of debt"
        if !$credits->count;

    while ( my $c = $credits->next ) {
        printf "%d) %s %s\n", $c->credId, $c->date, $c->purpose;
    }

    while (1) {
        print "Which credit do you want to target? ";
        chomp( my $input = <STDIN> );
        return $targets{ $var } = $input if $credits->find($input);
        warn "Credit ID $input is not a listed option.\n";
    }

}

sub make_transfers {
    print "Make transfers ...\n";

    if ( ! -t STDIN ) {
        croak "Input expected from interactive terminal";
    }

    my $search_opts = { order_by => { -asc => ['date'] } };
    my $avcredits = $db->resultset("AvailableCredits")->search(
        { $OPTS{source} ? (
             credId => { -in => TrsrDB::expand_ids($OPTS{source}) }
          ) : ()
        },
        $search_opts
    );
    my $transfers = $db->resultset("Transfer");

    CREDIT:
    while ( my $c = $avcredits->next ) {

        printf " * [%d] %s has %d available in credit %d) %s\n",
            $c->date, $c->account->ID, $c->difference, $c->credId, $c->purpose;

        my $suggestions = $c->suggested_to_pay->search(
            { $OPTS{target} ? (
                 billId => { -in => TrsrDB::expand_ids($OPTS{target}) }
              ) : ()
            },
            $search_opts
        );

        my $last_input = q{ };

        cond_txn_all {

            DEBIT:
            while ( my $s = $suggestions->next ) {
                printf "   - [%s] %s: %s? (%s)\b\b", $s->date, $s->billId,
                    $s->purpose, $last_input;
                chomp( my $input = <STDIN> );
                $input = $last_input if !length($input);
                if ( lc($input) =~ /^y(es)?$/i ) {
                    $transfers->create({
                        credId => $c->credId, billId => $s->billId
                    });
                }
                elsif ( !$input || lc($input) !~ /^no?$/i ) {
                    print "Input invalid!\n";
                    redo DEBIT;
                }
                $last_input = $input;
            }

        }
    }
}

sub balance_status {
    my ($with_report) = @_;
    print "Get balance status ...\n";
    my $results = $db->resultset("Balance");
    my $header = "\tavailbl\tearned\tspent\tpromise\tarrears\teven_until\n";
    print "ID", $header unless $with_report;
    while ( my $r = $results->next ) {
        my %val = $r->get_columns();
        if ($with_report) { _balance_report( $val{ID} ) }
        print join "\t", $with_report ? "Balance:\n$header" : $val{ID},
              map({ sprintf '%7d', $val{$_} } qw{
                    available earned spent promised arrears
                 }), $val{even_until};
        print "\n";
    }
}

sub _balance_report {
    my ($id) = @_;
    print "Report of account $id:\n", "=" x 76, "\n";
    my $rs = $db->resultset("Account")->find($id)->report();
    my ($i, $state) = (0, 1);

    my $c = 0;

    my $print_subline = sub {
        my $row = shift;
        $row->{value} /= 100;
        my $tab = " " x (2 + length $c);
        print wrap( $row->{value} > 0 ? "$c. " : $tab, $tab, sprintf(
            "\t%+f\t%s @ %s\n", @{$row}{qw/value purpose date/}
        ));
    };
    my $print_remainder = sub {
        my $c = $db->resultset("AvailableCredits")->find($c) // return;
        print " " x length( $c->credId ), " (+", $c->difference,
              " left available.)";
    };

    while ( my $row = $rs->next ) {
        $i++;
        my %d = $row->get_columns();
        if ( $c && !defined $d{credId} ) {
            print "--- Current arrears: ---\n";
            $c = 0;
            redo;
        }

        $d{credId} //= 0;
        if ( $d{value} > 0 ) {
            $print_remainder->() if $c;
            $c = $d{credId};
        }
        elsif( $d{credId} != $c ) {
            die "Unexpected transfer for credId $d{credId}!\n";
        }

        $print_subline->(\%d);

    }

    if ( !$i ) {
        print "Account is evened out, alright.\n";
    }    
}

} # End of package Commands

return 1 if caller;

package main;

use Getopt::Long;
use FindBin qw($Bin);
use lib $Bin;
BEGIN {
    if (!( $ARGV[0] eq 'makedb'
        || $ARGV[0] eq 'server'
        || $ARGV[0] eq 'sql'
       )) {
        require TrsrDB;
        TrsrDB->import(\$db);
    }
    elsif ( $ARGV[0] eq 'makedb' && -e $ENV{TRSRDB_SQLITE_FILE} ) {
        die "$ENV{TRSRDB_SQLITE_FILE} does exist.\n";
    }
}

Commands::set_txn_mode(undef, "each");

%OPTS = (
    'account' => \$ACCOUNT,
    'target-credit' => \%targets,
    'txn-mode' => \&Commands::set_txn_mode,
);
GetOptions( \%OPTS,
  'txn-mode=s', 'account|a=s', 'target|t=s', 'target-credit|tcr=i', 'source|s=s',
  'date|d=s', 'value|v=i', 'purpose|p=s', 'bill-id|b=s'
);
delete @OPTS{'account', 'target-credit', 'txn-mode'};

my %dispatcher = (
    charge => \&Commands::charge_account,
    ct  => sub {
        Commands::charge_account();
        Commands::make_transfers();
    },
    cts => sub {
        Commands::charge_account();
        Commands::make_transfers();
        Commands::balance_status();
    },
    ctr => sub {
        Commands::charge_account();
        Commands::make_transfers();
        Commands::balance_status(1);
    },
    makedb => sub {
        chdir($Bin);
        exec q[cat schema/tables.sql schema/*/*.sql]
           . q[| sqlite3 $TRSRDB_SQLITE_FILE];
    },
    report => sub {
        Commands::balance_status(1);
    },
    server => sub {
        exec qw{morbo server -w TrsrDB -w templates/};
    },
    sql => sub {
        exec "sqlite3",
             -cmd => "PRAGMA foreign_keys=ON; PRAGMA recursive_triggers=ON;",
             '-line', $ENV{TRSRDB_SQLITE_FILE};
    },
    status => \&Commands::balance_status,
    transfer => \&Commands::make_transfers,
    tr  => sub {
        Commands::make_transfers();
        Commands::balance_status(1);
    },
    ts  => sub {
        Commands::make_transfers();
        Commands::balance_status();
    }
);

my $cmd = shift;
if ( my $sref = $dispatcher{ $cmd } ) {
    $sref->();
}
else { 
    die qq{Command not supported: $cmd\n};
}