#!/usr/bin/perl

use strict;
use warnings;

use lib '/home/raj/perl5/lib/perl5';

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

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 $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 = '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 	=> '163.160.171.48', # full IP address to accept external connections
        LocalPort 	=> 9001,
        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

# two regex variants, for manual input (yy-nnnnn), and barcode scan (Hnnnnn/yy):
    my $re = qr!
#===============================================================================
# for manual input using yy-ddddd labno format; also adjust $str =~ /$re/ below:
#		D1U\d{16}        # yyyymmdd + sample ID padding (8 zeros)
#		(\d{2})-(\d{5})  # sample ID (2-digits + '-' + zero-padded 5-digits)
#-------------------------------------------------------------------------------
# for barcode scan of label (eg H01234/15); also adjust $str =~ /$re/ below:
		D1U\d{15}        # yyyymmdd + sample ID padding (7 zeros)
		H(\d{5})/(\d{2}) # sample ID (H + zero-padded 5-digits + '/' + 2-digits)
#===============================================================================
		(\w{6})          # PDA info
		\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 $re;

# for barcode scan of label (eg H01234/15):
    my ($request_number, $yr, @params) = $str =~ /$re/o;
# for manual input using yy-ddddd labno format:
#    my ($yr, $request_number, @params) = $str =~ /$re/o;
    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

    # does request already have a result:
    $dbix->select($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($tbl, { lab_number => $lab_number }); # warn 'OVERWRITE';
    }
    # insert new data:
    $dbix->insert($tbl, $data);

	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($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 $data = shift;

	my $msg = join "\n", 'SYSMEX POSSIBLE DATA CORRUPTION:', $data;
	$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
