#!/usr/bin/env perl

=begin
socket for sysmex haematology cell-counter, controlled by init.d & Daemon::Control
errors go to /run/sysmex/sysmex.out

configured to listen on host eth0 automatically using Net::Address::IP::Local
can be run in test mode using "sudo perl $0 [-p <port>][--test_mode] start"
    --test_mode forces listening to localhost only (lo adapter)
    --port optional (default 9001)
tail -f /run/sysmex/sysmex.out
tail -f ~/apps/hilis4/logs/sysmex.log
sudo perl $0 stop

to test, use netcat, with '_TEST_' in 6-char pda field:
echo 'D1U<yyyymmdd>0<sample ID>_TEST_<96-char numeric string>' | nc -w 1 \
    <listening_addr> <port> # -w = wait time (sec)

96-char numeric string example:
001151048000155004510094000323103440017000535000830038220062000100004300462001270009800084201310

sample ID format; always 15-chars; needs to match format defined in $regex or
input string gets dumped to logs/sysmex.log:
    000015_12345_RF
    000000H01234/15
    000000015-12345
=cut

use strict;
use warnings;

use lib '/home/raj/perl5/lib/perl5';
use Net::Address::IP::Local;

#-------------------------------------------------------------------------------
# address & port for host socket, port & host addr maybe overridden in test_mode:
my $host_addr = Net::Address::IP::Local->public_ipv4; # warn $host_addr; exit;
my $host_port = 9001;
my $test_mode = 0;

use Getopt::Long;
GetOptions (
    "test_mode"   => \$test_mode, # flag
    "port|p=i"    => \$host_port, # int
);
$host_addr = '127.0.0.1' if $test_mode; # warn $host_addr; warn $host_port; exit;

# 15-character zero-padded sample ID:
my $sample_id =
# yy-nnnnn:
#   '\d{7}' . '(\d{2})-(\d{5})'
# Hnnnnn/yy:
    '\d{6}' . 'H(\d{5})/(\d{2})'
# yy_nnnnn_RF:
#   '\d{4}' . '(\d{2})_(\d{5})_RF'
;
#-------------------------------------------------------------------------------

use IO::All;
use IO::Socket;
use IO::Handle;

use Try::Tiny;
use Data::Dumper;
use Data::Printer;
use Daemon::Control;
use Time::Out qw(timeout);

use FindBin qw($Bin);  # load AFTER local::lib Carp or FindBin loads system
use lib "$Bin/../lib";
use LIMS::Local::ScriptHelpers;

my $regex = qr!
    D1U\d{9}         # yyyymmdd + 1 char
    $sample_id       # 15-character zero-padded sample ID
	(\w{6})          # PDA info (also used for _TEST_ flag)
	\d               # RDW select || reserve
	([\d*]{4})(\d)   # wbc + flag
	([\d*]{4})(\d)   # rbc + flag
	([\d*]{4})(\d)   # hb + flag
	([\d*]{4})(\d)   # hct + flag
	([\d*]{4})(\d)   # mcv + flag
	([\d*]{4})(\d)   # mch + flag
	([\d*]{4})(\d)   # mchc + flag
	([\d*]{4})(\d)   # plt + flag
	([\d*]{4})(\d)   # lymph (%) + flag
	([\d*]{4})(\d)   # mixed (%) + flag
	([\d*]{4})(\d)   # neutr (%) + flag
	([\d*]{4})(\d)   # lymph (#) + flag
	([\d*]{4})(\d)   # mixed (#) + flag
	([\d*]{4})(\d)   # neutr (#) + flag
	([\d*]{4})(\d)   # rdw-sd + flag
	([\d*]{4})(\d)   # rdw-cv + flag
#	.*               # don't need remaining
!x; # p $regex; exit;

my $tools = LIMS::Local::ScriptHelpers->new();
$tools->use_path("$Bin/..");  # for ScriptHelpers to find correct path to app root

my $cfg = $tools->get_settings; # warn Dumper $cfg;

my $tbl_name = 'request_haematology';
my $log_file = "$Bin/../logs/sysmex.log";

my @fields = qw(
    pda wbc wbc_f rbc rbc_f hb hb_f hct hct_f mcv mcv_f mch mch_f mchc mchc_f
    plt plt_f lymph_percent lymph_percent_f mixed_percent mixed_percent_f
    neutr_percent neutr_percent_f lymph lymph_f mixed mixed_f neutr neutr_f
    rdw_sd rdw_sd_f rdw_cv rdw_cv_f
);

# flush after every write
$| = 1;
open my $fh, '>>', $log_file or die $!;
$fh->autoflush(1);

my %args = (
    name         => 'sysmex',
#    lsb_start   => '$syslog $remote_fs',
#    lsb_stop    => '$syslog',
    lsb_sdesc    => 'sysmex daemon',
    lsb_desc     => 'Controls the sysmex socket',
    path         => "$Bin/sysmex.pl",
    program      => \&open_socket,
    program_args => [ ],
    pid_file     => '/var/run/sysmex/sysmex.pid',
    stderr_file  => '/var/run/sysmex/sysmex.out',
    stdout_file  => '/var/run/sysmex/sysmex.out',
    fork         => 2,
);

Daemon::Control->new(\%args)->run;

sub open_socket {
    # open a socket:
    my $socket = IO::Socket::INET->new(
        LocalHost 	=> $host_addr, # full IP address to accept external connections
        LocalPort 	=> $host_port,
        Proto 		=> 'tcp',
        Listen 		=> 1,
        ReuseAddr	=> 1
    ) or die "Could not create socket: $!\n";

    our ($r); # output from sysmex analyser

    while ( my $client_socket = $socket->accept ) {
        # my $peer_addr = $client_socket->peerhost();
        # my $peer_port = $client_socket->peerport();
        # print "Accepted new client connection from $peer_addr, $peer_port\n";

        READ: # read in 131-char chunks:
        while ( timeout 30 => sub { $client_socket->read($r, 131) } ) { # warn Dumper $r;
            # print $fh DateTime->now->datetime . "\n$r\n";
            my $data = parse_data($r); # warn Dumper $data; # returns hashref or 0
            if ($data) {
                my $ok = process_data($data); # method returns 1 on success
                next READ if $ok;
            }
            do_log($r); # no $data or process_data() returns false
        }
    }

    close $socket;
}

sub parse_data {
	my $str = shift; # warn length $str;

    my %h = (); # data hash to return

    my (@params) = $str =~ /$regex/o; # warn Dumper [ @params[0,1] ];
    return 0 unless @params; # $str doesn't match regex

    my ($request_number, $yr);
    # for ddddd + yy formats:
    if ( length $params[0] == 5 && length $params[1] == 2 ) {
        ($request_number, $yr) = splice @params, 0, 2;
    }
    # for yy + dddddd formats:
    elsif ( length $params[0] == 2 && length $params[1] == 5 ) {
        ($yr, $request_number) = splice @params, 0, 2;
    } # warn Dumper [$request_number, $yr];
    return 0 unless $request_number && $yr && @params; # p $request_number; p $yr;

    # create hash of data:
	@h{@fields} = @params; # p %h;

    # add lab number (yy_nnnnn format):
    $h{lab_number} = sprintf '%02d_%05d', $yr, $request_number;
	return \%h;
}

sub process_data {
	my $data = shift;

	my $lab_number = $data->{lab_number};

	my $dbix = get_dbix(); # get new dbix object

=begin # to activate when request_haem table has new primary key
    # return if request already has verified result - will need to delete in app to over-write:
    return 0 if $dbix->select($tbl, 1,
        { lab_number => $lab_number, status => 'verified' })->list;
    # insert new data (can have multiple entries until verification):
    $dbix->insert($tbl, $data);
	return 1;
=cut

    # using pda field as flag for test function:
    my $dbname = $data->{pda} eq '_TEST_' ? 'lims_test' : 'hilis4'; # warn $dbname;
    my $db_tbl = join '.', $dbname, $tbl_name;

    # does request already have a result:
    $dbix->select($db_tbl, 1, { lab_number => $lab_number })->into(my $status);
    if ($status) { # exists - can only over-write if not already verified:
        return 0 if $status eq 'verified'; # can't overwite here (delete in app)
        $dbix->delete($db_tbl, { lab_number => $lab_number }); # warn 'OVERWRITE';
    }
    # insert new data, dbix error kills socket so catch & handle it:
    try {
        $dbix->insert($db_tbl, $data);
    }
    catch {
        alert_admin($dbix->error);
    };
	return 1;
}

sub do_log { # log with timestamp:
	my $data = shift;

	print $fh $tools->time_now->datetime . "\n$data\n" || warn $!;

	# leading char should be '02H' hex char; ord(02H) = 2, so chr(2) should re-encode for use in var:
	my $stx = chr(2); # warn Dumper $stx; - will be undef
    alert_admin( "SYSMEX POSSIBLE DATA CORRUPTION:\n" . $data )
        if $data !~ /^${stx}D1U/; # indicates possible data stream corruption
}

# return a new dbix object for each dataset - not using ScriptHelpers::get_dbix()
# to avoid cacheing db connection and MySQL timeout after >8hrs idle:
sub get_dbix {
    my $uid = $cfg->{db_user_id};
    my $pwd = $cfg->{db_password};
    my $db  = $cfg->{production_db};

    my $dsn = "dbi:mysql:$db";

    my $dbix = DBIx::Simple->connect($dsn, $uid, $pwd, { RaiseError => 1 });

    return $dbix;
}

sub alert_admin {
    my $msg = shift;
    my $now = $tools->time_now->datetime; warn "${now}: $msg";
	$tools->mail_admin({ script => io($0)->filename, msg => $msg });
}

__END__
#!/bin/sh

### BEGIN INIT INFO
# Provides:          sysmex
# Required-Start:
# Required-Stop:
# Default-Start:     2 3 4 5
# Default-Stop:      0 1 6
# Short-Description: sysmex daemon
# Description:       Controls the sysmex_daemon script
### END INIT INFO

SCRIPT_DIR=/home/raj/apps/HILIS4/script
SCRIPT=sysmex.pl

if [ -x $SCRIPT_DIR/$SCRIPT ];
then
    /usr/bin/perl $SCRIPT_DIR/$SCRIPT $1
else
    echo "Required program $SCRIPT_DIR/$SCRIPT not found!"
    exit 1;
fi