bpi

#! /usr/bin/env perl
#
use strict;
use warnings qw(FATAL);


my @gnuplot = ("gnuplot", "-p");


=pod

=head1 NAME

bpi.pl - download and plot MOEX Best Private Investor contest data

=head1 SYNOPSIS

  perl bpi.pl --update[=YEAR]
  perl bpi.pl [OPTIONS] SYMBOL

=head2 OPTIONS

=over

=item C<--update[=YEAR]>

Download new data and add it to database.  If year is not given current
year is assumed.

=item C<-b, --bond=PRICE>

Specify nominal bond price (aka "face value").

=item C<-i, --interval=MINUTES>

Candle time interval (in minutes).  Intervals are measured from
midnight and won't cross day boundary.  Default is 1440 minutes (1
day).

=item C<-f, --from=DATETIME>

Start time in format C<YYYY-MM-DD> or C<YYYY-MM-DD hh:mm>.  Start date
is inclusive.  Default is the beginning of data.

=item C<-t, --to=DATETIME>

End time in format C<YYYY-MM-DD> or C<YYYY-MM-DD hh:mm>.  End date is
not inclusive.  Default is the end of data.

=item C<--image=EXT,WIDTH,HEIGHT>

Create image file named F<SYMBOL.EXT> with size C<WIDTH> by C<HEIGHT>
pixels.  For example:

  --image=png,1920,1080 MGNT

will create 1920x1080 F<MGNT.png>, and

  --image=svg,1600,1200 AFLT

will create scalable F<AFLT.svg> with base dimensions 1600x1200.

When C<--image> is not given (the default) the graph will be shown in
an interactive window.

=item C<--fontscale=SCALE>

Scale font by C<SCALE> factor (float).  Default is 1.0.  You may set
this to lower value if labels overlap.

=item C<-r, --root=DIR>

Directory of F<YEAR.db> file(s) and where to put PNG file(s).
Default is the directory where this script is located.

Do not remove F<YEAR.db-journal> file if it exists or database will
become corrupt.

=item C<-h, --help>

Print this message and exit.

=back

=cut

my $VERSION = "1.1";


use Getopt::Long qw(:config gnu_getopt);
use Pod::Usage;
use FindBin;
use Net::FTP;
use Net::HTTP;
use Archive::Zip;
use Archive::Zip::MemberRead;
use DBI;


my %option = (
    update => undef,
    bond => 0,
    interval => 1440,
    from => "",
    to => "",
    image => "",
    fontscale => 1.0,
    root => $FindBin::Bin,
);
if (! GetOptions(\%option, qw(update:0 bond|b=i interval|i=i from|f=s to|t=s
                              image=s fontscale=f root|r=s help|h))
    || @ARGV != (defined $option{update} ? 0 : 1)) {
    pod2usage(1);
}
if (exists $option{help}) {
    pod2usage(0);
    exit;
}
$option{interval} *= 60;
$option{interval} = 60 if $option{interval} < 60;
$option{interval} = 86400 if $option{interval} > 86400;


my $year;
unless (defined ($year = $option{update})) {
    ($year) = $option{from} =~ /^(\d{4})/;
    ($year) = $option{to} =~ /^(\d{4})/ unless $year;
}
$year = (localtime)[5] + 1900 unless $year;


chdir($option{root})
    or die "Can't change to directory $option{root}: $!";


my $attrs = { AutoCommit => 1,
              PrintError => 0,
              RaiseError => 1 };
my $dbh = DBI->connect("DBI:SQLite:dbname=$year.db", "", "", $attrs);
$dbh->do(q{
    PRAGMA page_size = 4096
});
$dbh->do(q{
    CREATE TABLE IF NOT EXISTS source (
        id INTEGER NOT NULL PRIMARY KEY,
        dir INTEGER NOT NULL,
        market INTEGER NOT NULL,
        trader INTEGER NOT NULL,

        UNIQUE (trader, market, dir)
    )
});
$dbh->do(q{
    CREATE TABLE IF NOT EXISTS contest (
        source_id INTEGER NOT NULL REFERENCES source (id),
        date_time INTEGER NOT NULL,
        symbol TEXT NOT NULL,
        amount INTEGER NOT NULL,
        price FLOAT NOT NULL
    )
});
$dbh->do(q{
    CREATE VIEW IF NOT EXISTS vcontest AS
    SELECT contest.rowid AS rowid, dir, market, trader,
           datetime(date_time, 'unixepoch') AS date_time, symbol, amount, price
    FROM contest JOIN source ON source_id = id
});


if (defined $option{update}) {
    update_db();
} else {
    plot_graph();
}

exit 0;


sub update_db {
    $dbh->do(q{
        PRAGMA synchronous = OFF
    });

    my $source_exists = $dbh->prepare(q{
        SELECT 1
        FROM source
        WHERE dir = ? AND market = ? AND trader = ?
    });
    my $source_insert = $dbh->prepare(q{
        INSERT INTO source (dir, market, trader)
        VALUES (?, ?, ?)
    });
    my $contest_insert = $dbh->prepare(q{
        INSERT INTO contest (source_id, date_time, symbol, amount, price)
        VALUES (?, strftime('%s', ?), ?, ?, ?)
    });

    my $ftp_host = "ftp.moex.com";
    my $ftp_path = "/pub/info/stats_contest/$year";
    my $traders = "trader.csv";

    my $ftp = Net::FTP->new($ftp_host)
        or die "Can't connect to $ftp_host: $@";
    $ftp->login
        or die "Can't login to $ftp_host: ", $ftp->message;
    $ftp->cwd($ftp_path)
        or die "Can't change remote directory to $ftp_path: ", $ftp->message;

    $| = 1;
    $ftp->binary;

    foreach my $dir ($ftp->ls) {
        next unless $dir =~ /^20\d{6}$/;
        my @ls = $ftp->ls($dir);
        foreach my $file (@ls) {
            my ($market, $trader) = $file =~ /^([123])_(\d+)\.zip$/
                or next;

            next if $dbh->selectrow_array($source_exists, undef,
                                          $dir, $market, $trader);

            print "Fetching $dir/$file...";
            $dbh->begin_work;

            $source_insert->execute($dir, $market, $trader);
            my $source_id = $dbh->last_insert_id(undef, undef, undef, undef);

            $ftp->get("$dir/$file", "tmp.zip")
                or die "Can't fetch $dir/$file: ", $ftp->message;
            my $zip = Archive::Zip->new("tmp.zip");
            my $csv = Archive::Zip::MemberRead->new($zip,
                                                    "${market}_$trader.csv");
            while (my $line = $csv->getline) {
                my ($date_time, $symbol, $amount, $price) = split /;/, $line;
                $symbol =~ s/\s+//g;
                $contest_insert->execute($source_id, $date_time, $symbol,
                                         $amount, $price);
            }

            $dbh->commit;
            print "done\n";
        }
    }
    unlink "tmp.zip" if -e "tmp.zip";

    print "Fetching $traders...";
    $ftp->get($traders, "tmp.csv")
        or die "Can't fetch $traders: ", $ftp->message;
    $ftp->quit;
    print "done\n";

    # To avoid possible encoding problems on Windows we hardcode
    # market names as sequences of UTF-8 bytes.
    my %market_name2index = (
        # Fondovy
        "\x{d0}\x{a4}\x{d0}\x{be}\x{d0}\x{bd}\x{d0}\x{b4}\x{d0}\x{be}"
        . "\x{d0}\x{b2}\x{d1}\x{8b}\x{d0}\x{b9}" => 1,
        # Srochny
        "\x{d0}\x{a1}\x{d1}\x{80}\x{d0}\x{be}\x{d1}\x{87}\x{d0}\x{bd}"
        . "\x{d1}\x{8b}\x{d0}\x{b9}" => 2,
        # Valutny
        "\x{d0}\x{92}\x{d0}\x{b0}\x{d0}\x{bb}\x{d1}\x{8e}\x{d1}\x{82}"
        . "\x{d0}\x{bd}\x{d1}\x{8b}\x{d0}\x{b9}" => 3
    );

    open(my $fh, "<", "tmp.csv")
        or die "Can't open file tmp.csv: $!";
    while (<$fh>) {
        my ($trader) = /;(\d+)/;

        next if $dbh->selectrow_array($source_exists, undef, 0, 0, $trader);

        print "Fetching initial portfolio for $trader...";
        $dbh->begin_work;

        $source_insert->execute(0, 0, $trader);

        my @market_source_id;

        my $dates = fetch_json("GetDates",
                               "{'traderId':$trader,'isMy':0,'tableId':6}");
        my ($date) = $dates =~ /\\"(\d{4}-\d\d-\d\d)\\"}\]"}$/;
        unless ($date) {
            $dbh->rollback;
            print "missing\n";
            next;
        }

        my $portfolio = fetch_json("GetPortfolioData",
                             "{'traderId':$trader,'date':'$date','tableId':6}");

        $portfolio =~ s/^{"d":"\[//;
        while ($portfolio =~ /\G[^{]*({[^}]*})/g) {
            my $rec = $1;

            my ($pos, $change) = $rec =~ /"pos\\?"[^"]+"(-?\d+)\s+\(([+-]\d*)/;
            $pos -= $change if $change ne "-";
            next if $pos == 0;

            my ($seccode) = $rec =~ /"seccode\\?"[^"]+"([^ \\"]+)/;

            my ($cost) = $rec =~ /"cost\\?"[^"]+"(-?\d*(?:\.\d*)?)/;
            my ($saldo) = $rec =~ /"saldo\\?"[^\d+-]+([+-]?\d+(?:\.\d*)?)/;
            my $price = $cost ne "-" ? ($cost - $saldo) / $pos : 0;

            my ($contype_name) = $rec =~ /"contype_name\\?"[^"]+"([^ \\"]+)/;
            my $market = $market_name2index{$contype_name};

            unless (defined $market_source_id[$market]) {
                $source_insert->execute(0, $market, $trader);
                $market_source_id[$market] =
                    $dbh->last_insert_id(undef, undef, undef, undef);
            }
            $contest_insert->execute($market_source_id[$market],
                                     "$date 00:00:00", $seccode, $pos, $price);
        }

        $dbh->commit;
        print "done\n";
    }
    close $fh;
    unlink "tmp.csv";
}


sub fetch_json {
    my ($name, $request) = @_;

    my $http_host = "investor.moex.com";
    my $http_path = "/ru/statistics/$year/portfolio.aspx/$name";

    my $http = Net::HTTP->new(Host => $http_host)
        or die "Can't connect to $http_host: $@";
    $http->write_request(POST => $http_path,
                         "Content-Type" => "application/json", $request)
        or die "Can't POST $http_path: $@";
    my ($status, $message) = $http->read_response_headers;
    $status == 200 or die "$http_path request failed: $status $message";
    my $json = "";
    while (1) {
        my $buf;
        my $res = $http->read_entity_body($buf, 1024);
        defined $res or die "$http_path response read failed: $!";
        last unless $res;
        $json .= $buf;
    }
    return $json;
}


sub plot_graph {
    open(my $plot, "|-", @gnuplot)
        or die "Can't start @gnuplot: $!";
    print $plot "\$data << EOD\n"
        or die "Can't pipe to @gnuplot: $!";

    my %position = (
        total_amount_long => 0,
        total_amount_short => 0,
        total_money_long => 0,
        total_money_short => 0,
    );
    my $initial_seen = 1;
    my $interval_start = 0;
    my $interval_end = 0;
    my $x_tic = 0;
    my $x_tic_day = 0;
    my ($candle_open, $candle_low, $candle_high, $candle_close) = (0, 0, 0, 0);

    my $output_tic_points = sub {
        my ($no_labels) = @_;

        my $amount_long = $position{total_amount_long};
        my $price_long = ($amount_long
                          ? $position{total_money_long} / $amount_long
                          : "NaN");
        my $amount_short = -$position{total_amount_short};
        my $price_short = ($amount_short
                           ? -$position{total_money_short} / $amount_short
                           : "NaN");

        my $x_label = "";
        my $x2_label = "";
        unless ($no_labels) {
            my @date_time = gmtime($interval_start);
            $x_label = sprintf("%02d:%02d", @date_time[2, 1]);
            my $day = int($interval_start / 86400);
            if ($x_tic_day != $day) {
                $x_tic_day = $day;
                $x_label = sprintf("%02d/%02d $x_label",
                                   $date_time[4] + 1, $date_time[3]);
            }

            my $ratio = "  ";
            if ($amount_long && $amount_short) {
                if ($amount_long == $amount_short) {
                    $ratio = "=";
                } else {
                    $ratio = sprintf("%.1f", ($amount_long > $amount_short
                                              ? $amount_long / $amount_short
                                              : -$amount_short / $amount_long));
                }
            }
            my $gain_loss = "";
            if ($x_tic) {
                my $margin_short = 1;
                # Money to close short position.
                my $money_margin_short =
                    $candle_close * $amount_short * $margin_short;
                my $money_start =
                    ($position{total_money_long} + $money_margin_short
                     # Minus negative $position{total_money_short}.
                     + $position{total_money_short});
                my $money_end =
                    ($money_margin_short
                     + $candle_close * ($amount_long - $amount_short));
                $gain_loss = sprintf("(%.2f%%)",
                                     ($money_end / $money_start - 1) * 100);
            }
            $x2_label = "$ratio $gain_loss";
        }

        my $data = join(" ", $x_tic, qq{"$x_label"}, qq{"$x2_label"},
                        $price_long, $price_short, $amount_long, $amount_short);
        $data .= join(" ", "",
                      $candle_open, $candle_low, $candle_high, $candle_close)
            unless $initial_seen;
        print $plot $data, "\n"
            or die "Can't pipe to @gnuplot: $!";
    };

    my $select = $dbh->prepare(qq{
        SELECT dir = 0, trader, date_time, amount, price,
            @{[ $option{from} ? "date_time >= strftime('%s', ?)" : "?" ]}
        FROM contest JOIN source ON source_id = id
        WHERE symbol = ?
            AND @{[ $option{to} ? "date_time < strftime('%s', ?)" : "?" ]}
        ORDER BY date_time, contest.rowid
    });
    $select->execute($option{from} || 1, $ARGV[0], $option{to} || 1);
    $select->bind_columns(\my ($initial, $trader, $date_time,
                               $amount, $price, $in_range));
    my $bond_face2percent = $option{bond} ? 100 / $option{bond} : 0;
    while ($select->fetch) {
        $price *= $bond_face2percent if $bond_face2percent && $initial;

        if ($in_range) {
            if ($initial) {
                unless ($initial_seen) {
                    $output_tic_points->(1) if $x_tic;
                    $initial_seen = 1;
                }
            } elsif ($date_time >= $interval_end) {
                ($interval_start, $interval_end) = interval($date_time);
                $output_tic_points->();  # Flush either candle or step.
                $initial_seen = 0;
                ++$x_tic;

                $candle_open = $price;
                $candle_low = $price;
                $candle_high = $price;
                $candle_close = $price;
            } else {
                $candle_low = $price if $candle_low > $price;
                $candle_high = $price if $candle_high < $price;
                $candle_close = $price;
            }
        }

        position_update(\%position, $trader, $amount, $price);
    }
    if ($x_tic) {
        $interval_start = $interval_end;
        $output_tic_points->();  # Flush either final candle or step.
    }

    print $plot "EOD\n" or die "Can't pipe to @gnuplot: $!";

    die "No data to plot\n" unless $x_tic;

    if (my ($type, $size) = $option{image} =~ /^([^,]+),(\d+,\d+)$/) {
        print $plot qq{
            set terminal $type size $size
            set output "$ARGV[0].$type"
        } or die "Can't pipe to @gnuplot: $!";
    }
    print $plot qq{
        set termoption fontscale $option{fontscale}
        set grid xtics
        set xtics nomirror out rotate right
        set x2tics nomirror out rotate
        set ytics nomirror out
        set y2tics nomirror out
        set format y "%.0f"
        set boxwidth 0.65
        set key outside center top horizontal height 2 \\
            title "$ARGV[0] ($year)  [bpi.pl v$VERSION]"
        set x2label \\
            "Amount ratio (>1: long/short; <-1: -short/long), gain/loss percent"
        set ylabel "Amount"
        set y2label "Price"

        plot \$data using (\$1-0.5):8:9:10:11 axes x1y2 title "Price candle" \\
                 with candlesticks lc rgb "#0000ff", \\
             \$data using 1:4 axes x1y2 title "Long average price" \\
                 with lines lw 2 lc rgb "#00ff00", \\
             \$data using 1:5 axes x1y2 title "Short average price" \\
                 with lines lw 2 lc rgb "#ff0000", \\
             \$data using 1:6:xtic(2) axes x1y1 title "Long amount" \\
                 with lines lc rgb "#00a000" dt 3, \\
             \$data using 1:7:x2tic(3) axes x1y1 title "Short amount" \\
                 with lines lc rgb "#a00000" dt 3
    } or die "Can't pipe to @gnuplot: $!";
}


sub position_update {
    my ($position, $trader, $amount, $price) = @_;

    $position->{$trader} = { amount => 0, money => 0 }
        unless $position->{$trader};

    my $old_type = $position->{$trader}{amount} > 0 ? "long" : "short";
    $position->{"total_amount_$old_type"} -= $position->{$trader}{amount};
    $position->{"total_money_$old_type"} -= $position->{$trader}{money};

    $position->{$trader}{amount} += $amount;

    my $new_type = $position->{$trader}{amount} > 0 ? "long" : "short";
    if ($position->{$trader}{amount} && $new_type eq $old_type) {
        $position->{$trader}{money} += $amount * $price;
    } else {
        # Position has been closed or flipped, reset any previous gain/loss.
        $position->{$trader}{money} = $position->{$trader}{amount} * $price;
    }

    $position->{"total_amount_$new_type"} += $position->{$trader}{amount};
    $position->{"total_money_$new_type"} += $position->{$trader}{money};
}


sub interval {
    my ($date_time) = @_;

    # There are no daylight saving times and leap seconds to worry about.
    my $day_start = $date_time - $date_time % 86400;
    my $interval_start =
        $date_time - ($date_time - $day_start) % $option{interval};
    my $interval_end = $interval_start + $option{interval};
    $interval_end = $day_start + 86400 if $interval_end > $day_start + 86400;
    return ($interval_start, $interval_end);
}