#!/usr/bin/perl
### blkrsend.perl  -*- Perl -*-
## Send a file block-by-block.

### Ivan Shmakov, 2017, 2019

## To the extent possible under law, the author(s) have dedicated
## all copyright and related and neighboring rights to this software
## to the public domain worldwide.  This software is distributed
## without any warranty.

## You should have received a copy of the CC0 Public Domain Dedication
## along with this software.  If not, see
## <http://creativecommons.org/publicdomain/zero/1.0/>.

### History:

## 0.3  2019-11-01
##      Changed the protocol to use an explicit (hello, welcome)
##      handshake.  Implemented --read-blocks (-N).  Do not accept
##      the not actually implemented --execute= (-e) option.
##      Refuse to send (potentiall binary) data to a tty.

## 0.2  2017-06-24 14:00:32Z
##      (sfn.Bk_gxqpHjcveeH5szuMImXKy3e-dIxVf8BEPjaBK2ps.perl)
##      Implemented debug mode toggle via SIGUSR2.  Check flush return
##      value.  Send eof message.

## 0.1  2017-06-24 12:55:19Z
##      (sfn.R7UU8aFrR23tAOpvLQhPIJ0KnoMZkaoeF_AmFxKa0-o.perl)
##      Initial revision. 

### Code:

use common::sense;
use English qw (-no_match_vars);

# require Data::Dump;
require Digest::SHA;
require Getopt::Long;
require IO::File;
# require IO::Handle;
require IO::Select;

our $dev_fd_prefix
    = ($ENV{"DEVFDPREFIX"} // "/dev/fd/");

sub open_file {
    my ($fn, $mode) = @_;
    ## .
    return ("GLOB" eq ref ($fn) ? IO::File->new_from_fd ($fn->fileno (), $mode)
            : ($fn eq "-") ? (index ($mode, ">") > 0 ? \*STDOUT : \*STDIN)
            : do {
                  $mode
                      //= "<";
                  my $l
                      = length ($dev_fd_prefix);
                  ## .
                  ((substr ($fn, 0, $l) eq $dev_fd_prefix)
                   ? IO::File->new_from_fd (substr ($fn, $l), $mode)
                   : IO::File->new ($fn, $mode));
            });
}

## main

Getopt::Long::Configure (qw (gnu_compat));

our ($debug_p);
# my ($command_s)
#     = ();
my ($blk_z_default, $blk_start, $blk_count, $blk_z)
    = (0x10000, 0);

my $parsable_p
    = Getopt::Long::GetOptions (q (block-size=i)    => \$blk_z,
                                q (debug!)      => \$debug_p,
                                # "e|execute=s"   => \$command_s,
                                "N|read-blocks=i"   => \$blk_count,
                                "j|skip-blocks=i"   => \$blk_start)
    or die ("Cannot parse command line arguments");

require Data::Dump
    if ($debug_p);

die ("Exactly one non-option argument expected")
    unless (1 == @ARGV);
my $fn
    = $ARGV[0];
my $fh
    = open_file ($fn, "r")
    or die ($fn, ": Cannot open file: ", $!);
$fh->binmode ()
    or die ($fn, ": Cannot set binary mode: ", $!);

my $d0
    = Digest::SHA->new (256);

sub exit_on_signal {
    warn ("N: Got SIG", $_[0], ", exiting\n");
    exit (0);
}

## FIXME: add handlers, not replace?
@SIG{qw {TERM QUIT INT}}
    = (\&exit_on_signal) x 3;
$SIG{"__DIE__"} = sub {
    die ($PROGRAM_NAME, ": ", @_);
};

my ($x_in, $x_out)
    = (\*STDIN, \*STDOUT);
## FIXME: add handlers, not replace?
$SIG{"USR2"} = sub {
    $debug_p
        = ! $debug_p;
    warn ("N: Debug mode is now ", $debug_p ? "on" : "off");
    require Data::Dump
        if ($debug_p);
    $x_out->flush ()
        or warn ("Cannot flush output: ", $!);
};

$x_out->binmode ()
    or die ("Cannot set binary mode: ", $!);
my ($sel_r, $sel_w)
    = (IO::Select->new ($x_in),
       IO::Select->new ($x_out));
my ($next, $hello_seen_p, $sha_done_p, $req_done_p)
    = ($blk_start, 0, 0, 0);
my ($last_req, $filesize, @pending)
    = ();
while (! $sha_done_p || (! $req_done_p || @pending > 0)) {
    # warn ("D: Done? ",
    #       join (", ", ($sha_done_p ? ("sha") : ()),
    #                   ($req_done_p ? ("req") : ()),
    #             @pending), "\n")
    #     if ($debug_p);
    my @ready
        = IO::Select->select ((! $req_done_p ? $sel_r : undef),
                              (($hello_seen_p
                                && (! $sha_done_p || @pending > 0))
                               ? $sel_w : undef));
    ## FIXME: the conditionals could be clearer, I guess
    if (@ready >= 2) {
        ## do nothing
    } elsif ($! =~ /interrupted/i) {
        next;
    } else {
        die ("select call failed: ", $!)
            unless (@ready >= 2);
    }
    my ($in, $out)
        = (map { $_->[0]; } (@ready[0, 1]));
    if (defined ($in)) {
        my $request
            = $in->getline ();
        warn ("D: Got: ", scalar (Data::Dump::dump ($request))) if ($debug_p);
        unless (defined ($request)) {
            $req_done_p
                = 1;
            next;
        }

        ## FIXME: a specific parameter order is currently expected
        my ($hello_p, $h_size, $h_start, $h_count, $block)
            =  ($request =~ m {
                    ^ (hello) \s+ -
                      (?: \s+ size \s+ (\d+))?
                      (?: \s+ digest \s+ sha256)?
                      (?: \s+ start \s+ (\d+))?
                      (?: \s+ count \s+ (\d+))?
                      \s* $
                    | ^ send \s+ (\d+) \s* $
            }xi)
            or die ("Unrecognized request");
        if (! defined ($hello_p)) {
            $last_req
                //= -1 + $blk_start;
            die ("Unexpected block number to send: ", $block,
                 " (expected one in range ", 1 + $last_req,
                 " .. ", -1 + $next)
                unless ($last_req < $block && $block < $next);
            push (@pending, $block);
            $last_req
                = $block;
        } elsif ($hello_seen_p) {
            die ("Unanticipated second hello")
        } else {
            $hello_seen_p
                = 1;
            if (! defined ($h_size)) {
                $blk_z
                    = $blk_z_default;
            } else {
                $blk_z
                    //= $h_size;
                die ("Unexpected block size",
                    " (got ", $h_size, ", expected ", $blk_z, ")")
                    unless ($h_size == $blk_z);
            }
            if (defined ($h_start)) {
                die ("Unexpected start block",
                     " (got ", $h_start,
                     ", expected at least ", $blk_start, ")")
                    unless ($h_start >= $blk_start);
                $blk_start
                    = $h_start;
                $next
                    = $blk_start
                    if ($next < $blk_start);
            }
            if (defined ($h_count)) {
                ## FIXME: check against file size as well
                my $blk_count_max
                    = (! defined ($blk_count) ? undef
                       : $blk_count + $blk_start - $h_start);
                die ("Unexpected block count",
                     " (got ", $h_count,
                     ", expected less than ", $blk_count_max, ")")
                    unless (! defined ($blk_count_max)
                            || $h_count < $blk_count);
                $blk_count
                    = $h_count;
            }

            ## NB: can block here
            $x_out->print  ("welcome -",
                            " size ", $blk_z,
                            " digest sha256",
                            " start ", $blk_start,
                            (defined ($blk_count)
                             ? (" count ", $blk_count) : ()),
                            "\n");
            $x_out->flush ()
                or warn ("Cannot flush output: ", $!);
        }
    }
    if (! defined ($out)) {
        ## do nothing
    } elsif (@pending > 0) {
        ## read and send the block
        my $blk
            = shift (@pending);
        my $o
            = ($blk_z * $blk);
        $fh->seek ($o, 0)
            or die ($fn, ": Cannot seek (to ", $o, "): ", $!);
        my $s;
        my $rd
            = $fh->read ($s, $blk_z);
        die ($fn, ": Cannot read (", $blk_z, " at ", $o, "): ", $!)
            unless (defined ($rd) && $rd > 0);
        warn ("W: ", $fn, ": Short read",
              " (got ", $rd, " of ", $blk_z, " at ", $o, "): ", $!)
            unless ($rd == $blk_z);
        $out->print ("block ", $blk, " size ", $rd, "\n");
        die ("Will not send data to a tty")
            if (-t $x_out);
        $out->write ($s, $rd)
            or die ("Cannot write",
                    " (", $rd, " of block ", $blk, "): ", $!);
        ## NB: or else we may wait for each other instead.
        $x_out->flush ()
            or warn ("Cannot flush output: ", $!);
    } elsif (! $sha_done_p) {
        ## read the next block and send its SHA
        my $o
            = ($blk_z * $next);
        $fh->seek ($o, 0)
            or die ($fn, ": Cannot seek (to ", $o, "): ", $!);
        my $s;
        my $rd
            = $fh->read ($s, $blk_z);
        if (! defined ($rd)) {
            die  ($fn, ": Cannot read (", $blk_z, " at ", $o, "): ", $!)
        } elsif ($rd == $blk_z) {
            ## do nothing
        } else {
            warn ("W: ", $fn, ": Short read",
                  " (got ", $rd, " of ", $blk_z, " at ", $o, "): ", $!)
                if ($rd > 0);
            $filesize
                = ($o + $rd);
            $sha_done_p
                = 1;
            warn ("I: Filesize: ", $filesize, "\n");
            unless ($rd > 0) {
                $out->print ("eof\n");
                ## NB: or else we may wait for each other instead.
                $x_out->flush ()
                    or warn ("Cannot flush output: ", $!);
                next;
            }
        }
        $out->print ("block ", $next, " size ", $rd, " sha256 ",
                     $d0->clone ()->add ($s)->b64digest (),
                     ($sha_done_p ? (" last ") : ()), "\n");
        ## NB: or else we may wait for each other instead.
        if ($sha_done_p) {
            $x_out->flush ()
                or warn ("Cannot flush output: ", $!);
        }
        ++$next;
    }
}

warn ("I: Done: ",
      join (", ", ($sha_done_p ? ("sha") : ()),
                  ($req_done_p ? ("req") : ())), "\n");

### Emacs trailer
## Local variables:
## coding: us-ascii
## fill-column: 72
## indent-tabs-mode: nil
## ispell-local-dictionary: "american"
## End:
### blkrsend.perl ends here