#!/usr/bin/perl
# MBus daemon (Perl impl)
# Uses non-blocking IO
#

use strict;
use warnings;

use Socket;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use Errno 'EWOULDBLOCK';
use Getopt::Long qw(:config no_ignore_case bundling);
use Log::Log4perl "get_logger";
use Master::Conf;
use SKM::Common "ProcName";
use NextCAM::Conf "GetCfgs";
use NextCAM::WEBSession;

# CONS
#
my $APL = $ENV{APL};
my $APL_CONF = $ENV{APL_CONF};
my $TRUSTED_HOSTS = "$APL_CONF/trusted_hosts";
my $SESS_DIR = $^O=~/darwin/i ? '/tmp' : '/var/lib/php/session';

my $PROTOCOL_VERSION = 1;
my $MBUS_PORT = 10000;
my $BUFSIZ = 65535; # Socket read buffer size
my $TMT_SOCK = 0.5; # Timeout for 'select'
my $VACUUM_INTERVAL = 10;
my $OUTBUFFER_MAX = 10 * (1024 ** 2); # 10M per client by default
my $INT_MAX = 2 ** 31 - 1;

my $CHUNK_HDR_LEN = 12;
my $DEVID_ANY = '0';
my $DEVIP_ANY = '0.0.0.0';
my $AUTH_NONE = 0;
my $AUTH_SESSION = 1;

# VARS
#
my $ServerSock; # Server socket
my %Clients;
my %TrustedHosts; # IPs of SKM domain hosts
my $IsDaemon = 0;
my $EnableAuth = 1; # Verify client's IP or session
my $LastVacuumed = time;
my $LastSkipReport = 0;
my $DEBUG = $ENV{DEBUG};

# LOGGING
Log::Log4perl::init_and_watch("$APL/common/etc/logger_mbus.conf", 60);
my $log = get_logger('messageServer');

# SIGNALS
#
$SIG{PIPE} = 'IGNORE';

my ($rin, $rout, $win, $wout) = ('','','','');

# ROUTINES
#
sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

sub get_usage
{
	my $usage = ProcName;
	$usage .= " options\nOptions:\n";

	$usage .= "-h     --help                    Display this information\n";
	$usage .= "-D     --Daemon                  Run this program as daemon process\n";
	$usage .= "--disableAuth                    Any client is allowed to interact with broker\n";

	$usage;
}

sub crc
{
	return unpack('L',$_[0]) ^ $_[1];
}

sub hdr
{
	return $_[0].pack('L2',$_[1],crc($_[0],$_[1]));
}

# Reads 'TEXT' subchunk
#
sub read_text
{
	my ($sign, $len, $crc, $txtlen) = unpack('a4L3',substr($_[0],0,$CHUNK_HDR_LEN+4,''));
	return substr($_[0], 0, $txtlen, '');
}
# Reads 'SPEC' subchunk
sub read_spec
{
	substr($_[0], 0, $CHUNK_HDR_LEN) = '';
	my $devip = read_text($_[0]);
	my $devid = read_text($_[0]);
	my ($ct, $et, $pl, $msgid) = unpack('L4', substr($_[0], 0, 16, ''));
	return { 
		devip => $devip, 
		devid => $devid, 
		ct    => $ct, 
		et    => $et, 
		pl    => $pl, 
		msgid => $msgid 
	};
}

sub write_text
{
	my $len_t = length($_[0]);
	my $len_c = $len_t + 8;
	$_[1] .= 'TEXT'.pack('L3',$len_c,crc('TEXT',$len_c),$len_t).$_[0];
	return $len_c + 8; # total chunk length
}

sub write_spec
{
	my $sub = $_[0];
	
	my $spec = '';
	my $len = 20;
	$len += write_text($sub->{devip}, $spec);
	$len += write_text($sub->{devid}, $spec);
	$spec .= pack('L4',$sub->{ct},$sub->{et},$sub->{pl},$sub->{msgid});
	$_[1] .= 'SPEC'.pack('LL',$len,crc('SPEC',$len)).$spec;
	return $len + 8; # total chunk length
}

sub write_slst
{
	my $slst = '';
	my $len_s = 8; # crc(4) + subscnt(4)
	my $subscnt = 0;
	foreach my $id (keys %Clients) {
		my $sbr = $Clients{$id};
		foreach my $sub (@{$sbr->{subscriptions}}) {
			$subscnt++;
			$len_s += write_spec($sub, $slst);
			$len_s += write_text("$sbr->{ip}:$sbr->{port}", $slst);
		}
	}
	$_[0] .= hdr('SLST',$len_s).pack('L',$subscnt).$slst;
	return $len_s + 8; # total chunk length
}

sub write_ackw
{
	my ($request, $result, $param) = @_;
	# 4th arg is a buffer where to write
	my $ackw = $request.pack('L',$result);
	my $len_a = 12; # crc(4) + request(4) + result(4)
	for ($request) {
		/^CONN$/ && do {
			$len_a += 8;
			$ackw .= pack('L', $param);
			$ackw .= pack('L', $PROTOCOL_VERSION);
			last;
		};
		/^(SUBS|UNSB)$/ && do {
			$len_a += 4;
			$ackw .= pack('L', $param);
			last;
		};
		/^LIST$/ && do {
			$len_a += write_slst($ackw);
			last;
		};
	}
	
	$_[3] .= hdr('ACKW',$len_a).$ackw;
}

sub write_echo_ack
{
	my ($checkid) = @_;
	$_[1] .= hdr('EACK',8).pack('L',$checkid);
}

sub subs_match
{
	my ($s1, $s2) = @_;
	
	my $match = 0;
	# First compare features. 
	# Each of them should give non-null bitwise AND result
	#
	if ( !($s1->{ct} & $s2->{ct}) || !($s1->{et} & $s2->{et}) || !($s1->{pl} & $s2->{pl}) ) {
		return 0;
	}
		
	# Next check device_ID
	# They should be equal or 'broadcast' ones to match
	#
	if ( !($s1->{devid} eq $s2->{devid} || $s1->{devid} eq $DEVID_ANY || $s2->{devid} eq $DEVID_ANY) ) {
		return 0;
	}
		
	# Finally check device_IP
	# They should be equal or 'broadcast' ones to match
	#
	if ( !($s1->{devip} eq $s2->{devip} || $s1->{devip} eq $DEVIP_ANY || $s2->{devip} eq $DEVIP_ANY) ) {
		return 0;
	}
	
	return 1;
}

sub get_sid
{
	return int(rand($INT_MAX));
}

sub check_session
{
	my ($session) = shift;
	
	my $sinfo = WEBSessionAttr($session, 0, 0);
	return (0, 0) unless defined $sinfo;
	return (1, $sinfo->{userid});
}

sub update_trusted_list
{
	%TrustedHosts = ();
	
	# Get list of all nodes in domain
	#
	my $nlist = NodeList;
	foreach (keys %{$nlist}) {
		$TrustedHosts{ $nlist->{$_}{IP} } = $nlist->{$_}{UNI};
	}
	# Read 'trusted_hosts' file
	#
	if (open(TH, $TRUSTED_HOSTS)) {
		my @hosts = <TH>;
		close TH;
		foreach my $host (@hosts) {
			chomp $host;
			next unless $host;
			if  ($host =~ /[^\d\.]/) {
				# Suppose this is a domain name
				my $packed_ip = gethostbyname($host);
				if (defined $packed_ip) {
        				my $ip = inet_ntoa($packed_ip);
        				$TrustedHosts{$ip} = $ip;
            			}
			}
			else {
				# Support this is IP address
				$TrustedHosts{$host} = $host;
			}
		}
	}
	# Add Display Servers to trusted list
	#
	my %ds = GetCfgs('DEVICETYPE'=>'MONITOR');
	foreach my $obj (keys %ds) {
		$TrustedHosts{$ds{$obj}{TCP_IP}} = 1 if $ds{$obj}{STATE} eq 'on';
	}
	# Add 'localhost' to %Trustedhosts
	#
	$TrustedHosts{'127.0.0.1'} = 1;
}

sub nonblock 
{
	my $socket = shift;
	my $flags;
	    
	$flags = fcntl($socket, F_GETFL, 0)
		|| $log->logdie("Can't get flags for socket: $!");
	fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
		|| $log->logdie("Can't make socket nonblocking: $!");
		
	# Set autoflush
	my $oldfh = select($socket); $| = 1; select($oldfh);
}

sub remove_client
{
	my $id = shift;
	
	my $client = $Clients{$id};
	if ($client) {
		my $sock = $client->{sock};
		$log->info("remove client from ".$client->{ip}." port ".$client->{port}." helo=$client->{helo}");
		# remove socket fd from 'select' bitmasks
		vec($rin, fileno($sock), 1) = 0;
		vec($win, fileno($sock), 1) = 0;
		# remove socket from global cache
		delete $Clients{$id};
		close $sock;
	}
	else {
		$log->info("remove_client() called for id=$id, but no such record in cache");
	}
}

sub start_server
{	
	# Create listen socket and bind it
	# 
	socket($ServerSock, PF_INET, SOCK_STREAM, getprotobyname('tcp'))
		|| die "socket: $!";
	setsockopt($ServerSock, SOL_SOCKET, SO_REUSEADDR, pack("L", 1))
		|| die "setsockopt: $!";
	bind($ServerSock, sockaddr_in($MBUS_PORT, INADDR_ANY))
		|| die "bind: $!";
	listen($ServerSock, SOMAXCONN)
		|| die "listen: $!";
		
	# Daemonize if option set
        #
        if ($IsDaemon) {
		chdir '/';
		open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
		open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
		
		defined(my $pid = fork) or die("Can't fork: $!");
		exit if $pid;
		
		open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
        }
}

sub handle_input
{
	my ($client) = @_;
	
	my $keep_reading = 1;
	
	while ($keep_reading) {
		# Read and parse chunk header
		#
		unless (defined $client->{cur_chunk}) {
			# Got incomplete chunk. Skip it and wait for the rest
			#
			if (length($client->{inbuffer}) < $CHUNK_HDR_LEN) {
				$client->{wait_bytes} = $CHUNK_HDR_LEN - length($client->{inbuffer});
				$log->debug("incomplete header: waitfor $client->{wait_bytes}") if $DEBUG;
				$keep_reading = 0;
			}
			else {
				my $hdr  = substr($client->{inbuffer}, 0, $CHUNK_HDR_LEN, '');
				my ($sign, $len, $crc) = unpack('a4LL', $hdr);
				# Cannot correctly handle CRC error - remove client
				#
				if (crc($sign,$len) ne $crc) {
					$log->error("BAD CRC for chunk $sign: disconnect client $client->{desc}");
					remove_client($client->{id});
					return;
				}
				
				$client->{cur_chunk} = $sign;
				$client->{cur_chunk_len} = $len - 4; # substract length of crc
				if (length($client->{inbuffer}) < $len - 4) {
					$client->{wait_bytes} = $len - 4 - length($client->{inbuffer});
					$log->debug("incomplete chunk: waitfor $client->{wait_bytes}") if $DEBUG;
					$keep_reading = 0;
				}
			}
		}
		else  {
			$log->debug("got new chunk: $client->{cur_chunk}") if $DEBUG;
			for ($client->{cur_chunk}) {
				my $chunk = substr($client->{inbuffer}, 0, $client->{cur_chunk_len}, '');
				
				# Login
				#
				/^CONN$/ && do {
					my $auth_ok = ! $EnableAuth;
					my $userid = 0;	# Unknown/system user by default
					if ($EnableAuth) {
						if  ($client->{cur_chunk_len} > 0) {
							my $auth_type = unpack('L', substr($chunk, 0, 4, ''));
							if ($auth_type == $AUTH_SESSION) {
								my $session = read_text($chunk);
								($auth_ok, $userid) = check_session($session);
							}
							else {
								update_trusted_list;
								$auth_ok = exists $TrustedHosts{$client->{ip}};
							}
							# Read client's self-identification message if any
							if (length $chunk) {
							    my $helo = read_text($chunk);
							    $log->info("Client $client->{id} says: $helo");
							    $client->{helo} = $helo;
							    $client->{desc} = "$client->{id} [$helo]";
							}
						}
						else { # Old-style auth
							$auth_ok = exists $TrustedHosts{$client->{ip}};
						}
					}
					# Simply disconnect client if auth failed
					#
					unless ($auth_ok) {
						$log->info("Bad auth:  client $client->{desc}");
						remove_client($client->{id});
						return;
					}
					my $sid = get_sid;
					$client->{sid} = $sid;
					$client->{userid} = $userid;
					if ($userid != 0) { # Web client
					    $log->info("Client $client->{id} has userId=$userid");
					}
					write_ackw('CONN', 0, $sid, $client->{outbuffer});
					last;
				};
				# Subscribe
				#
				/^SUBS$/ && do {
					my $sid = unpack('L', substr($chunk, 0, 4, ''));
					my $sub = read_spec($chunk);
					$sub->{id} = get_sid;
					push(@{$client->{subscriptions}}, $sub);
					write_ackw('SUBS', 0, $sub->{id}, $client->{outbuffer});
					last;
				};
				# Unsubscribe
				#
				/^UNSB$/ && do {
					my ($sid, $subid) = unpack('LL', substr($chunk, 0, 8, ''));
					my $rSb = $client->{subscriptions};
					for(my $i=0; $i<@$rSb; $i++) {
						splice(@$rSb,$i,1),last if $rSb->[$i]{id} == $subid;
					}
					write_ackw('UNSB', 0, $subid, $client->{outbuffer});
					last;
				};
				# List subscriptions
				#
				/^LIST$/ && do {
					my $sid = unpack('L', substr($chunk, 0, 4, ''));
					write_ackw('LIST', 0, undef, $client->{outbuffer});
					last;
				};
				# Echo request
				#
				/^ECHO$/ && do {
					my $checkid = unpack('L', substr($chunk, 0, 4, ''));
					write_echo_ack($checkid, $client->{outbuffer});
					last;
				};
				# Data
				#
				/^DATA$/ && do {
					# "Dirty" parsing for optiimization purposes
					#
					# TP1403: 'userid' field added into DATA chunk (shift += 4)
					# Now DATA chunk structure is as follows:
					# DATA_HDR(12) | userid(4) | SPEC_HDR(12) | SPEC(?) | DATA(?)
					#
					my $ip_len = unpack('L', substr($chunk, 28, 4));
					my $devip  = substr($chunk, 32, $ip_len);
					my $id_len = unpack('L', substr($chunk, 44+$ip_len, 4));
					my $devid  = substr($chunk, 48+$ip_len, $id_len);
					my ($ct, $et, $pl, $msgid) = 
						unpack('L4', substr($chunk, 48+$ip_len+$id_len, 16));
					
					my $dst = {
						devip => $devip,
						devid => $devid,
						ct    => $ct,
						et    => $et,
						pl    => $pl,
						msgid => $msgid
					};
					
					# Forward this chunk to all subscribers which 
					# subscriptions match the requirements
					#
					foreach my $id (keys %Clients) {
						next if $id eq $client->{id};
						my $sbr = $Clients{$id};
						my @slst = @{$sbr->{subscriptions}};
						next unless @slst;
						foreach my $s (@slst) {
							if (subs_match($s, $dst)) {
								if (length($sbr->{outbuffer}) > $sbr->{outbuffer_max}) {
									$sbr->{skipped_count}++;
									if (time != $LastSkipReport) {
									    $log->info("Skipping chunk! for $sbr->{desc}".
										    " ($sbr->{skipped_count} total)");
									    $LastSkipReport = time;
									}
									next;
								}
								my $len = length($chunk) + 4;
								my $hdr = 'DATA'.pack('LL',$len,crc('DATA',$len));
								# Set userid
								substr($chunk,0,4) = pack('L',$client->{userid});
								$sbr->{outbuffer} .= ($hdr.$chunk);
								$log->debug("send DATA to $sbr->{ip}:$sbr->{port}") if $DEBUG;
							}
						}
					}
					last;
				};
			}
			
			$client->{cur_chunk} = undef;
			$client->{cur_chunk_len} = 0;
		}
		
		# No chunks remained in buffer
		#
		if ( ! length($client->{inbuffer}) && ! $client->{cur_chunk}) {
			$keep_reading = 0;
		}
	} # while ($keep_reading)
}

sub vacuum
{

	foreach my $id (keys %Clients) {
		my $client = $Clients{$id};
		
		# Disconnect connected but still unauthorized clients
		#
		if ($client->{sid} == 0 && time - $client->{utc_connected} > 20) {
			$log->warn("Disconnect client $client->{desc}. Reason: not authorized for >20 sec");
			remove_client($id);
			next;
		}
		# Disconnect clients unable to process incoming chunks for too long
		#
		if ($client->{pending_bytes} && time - $client->{last_write} > 20) {
			$log->warn("Disconnect client $client->{desc}. Reason: unable to send data to the client for >20 sec");
			remove_client($id);
			next;			
		}
	}
	
	$LastVacuumed = time;
}

sub event_loop
{
	vec($rin, fileno($ServerSock), 1) = 1;
	
	while (1) {
		
		my $time = time;
	
		# Do vacuuming
		#
		if ($time - $LastVacuumed > $VACUUM_INTERVAL) {
			vacuum;
		}
		
		# Server logic is here!
		# Process existing client data
		#
		foreach my $id (keys %Clients) {
			my $client = $Clients{$id};
			# Skip inactive and waiting-for-complete-chunk clients
			next unless length($client->{inbuffer});
			next if $client->{wait_bytes} > 0;
			
			handle_input($client);
		}
		
		# Do not trace writing capabilities if no one has data to send
		#
		$win = '';
		$wout = undef;
		foreach my $id (keys %Clients) {
			my $client = $Clients{$id};
			next unless length($client->{outbuffer});
			vec($win, fileno($client->{sock}), 1) = 1;
		}
		$wout = $win if $win;
		
		my $nfound = select($rout=$rin, $wout, undef, $TMT_SOCK);
		next unless $nfound;
		
		if ($nfound == -1) {
			$log->logdie("select: $!");
		}
		
		if (vec($rout, fileno($ServerSock), 1)) { # New connection
			my $clientsock;
			my $paddr = accept($clientsock, $ServerSock) || do {
				# try again if accept() returned because a signal was received
				next if $!{EINTR};
				$log->logdie("accept: $!");
			};
			my ($port, $iaddr) = sockaddr_in($paddr);
			#my $name = gethostbyaddr($iaddr, AF_INET);

			$log->info("connection from [",
				inet_ntoa($iaddr),
				"] at port $port ");
				
			nonblock $clientsock;
			
			my $id = inet_ntoa($iaddr).'_'.$port;
			$Clients{$id} = 
			{
				id            => $id,
				sock          => $clientsock,
				ip            => inet_ntoa($iaddr),
				port          => $port,
				utc_connected => $time,
				sid           => 0,
				userid        => 0,
				helo          => '',
				desc          => $id,
				inbuffer      => '',
				outbuffer     => '',
				subscriptions => [],
				# Implementation-specific attrs
				wait_bytes    => 0,
				cur_chunk     => undef,
				last_chunk    => undef,
				cur_chunk_len => 0,
				skipped_count => 0,
				outbuffer_max => $OUTBUFFER_MAX,
				vacuum        => {} # Attributes required for garbage collector
				
			};
			
			vec($rin, fileno($clientsock), 1) = 1;
			#vec($win, fileno($clientsock), 1) = 1;
			$nfound--;
		}
		
		foreach my $id (keys %Clients) {
			last if $nfound <= 0;
			
			my $client = $Clients{$id};
			my $sock = $client->{sock};
			# New data available on socket
			#
			if (vec($rout, fileno($sock), 1)) {
				$nfound--;
				
				my $rc = sysread(
					$sock, 
					$client->{inbuffer}, 
					$BUFSIZ, 
					length($client->{inbuffer})
				);
				
				if (defined $rc) {
					if ($rc > 0) {
						#logmsg "got $rc bytes from $id" if $rc > 30000;
						$client->{wait_bytes} -= $rc if $client->{wait_bytes}>0;
					}
					else { # EOF received
						$nfound-- if $wout && vec($wout, fileno($sock), 1);
						remove_client($id);
						next;
					}
				}
				elsif ($! == EWOULDBLOCK) { # Operation will block
				}
				else {
					$log->info("sysread() error: $!");
					$nfound-- if $wout && vec($wout, fileno($sock), 1);
					remove_client($id);
					next;
				}
			}
			# Socket is ready to write
			#
			if (defined $wout && $nfound && vec($wout, fileno($sock), 1)) {
				$nfound--;
				$client->{last_write} = $time;
				$client->{pending_bytes} = 0;
				# Send chunks if any
				if ($client->{outbuffer}) {
					my $rc = syswrite($sock, $client->{outbuffer});
					
					if ($rc > 0) {
						if ($rc < length($client->{outbuffer})) {
							substr($client->{outbuffer},0,$rc) = '';
						}
						else {
							$client->{outbuffer} = '';
						}
					}
					elsif ($! == EWOULDBLOCK) {
					}
					else {
						$log->info("syswrite() error: $!");
						remove_client($id);
					}
				}
			}
			elsif (length($client->{outbuffer})) {
				$client->{pending_bytes} = length($client->{outbuffer});
			}
		}
	}
}

sub configure
{
	# Parse command-line options
	#
	GetOptions (
		'help|h'                       => sub { print get_usage; exit },
		'Daemon|D'                     => \$IsDaemon,
		'disableAuth'                  => sub { $EnableAuth = 0 }
	) or die "Invalid command line option. Usage: ".get_usage;
	
	$log->info("--- Starting MBus broker (perl edition) (PID=$$) ---");
	
	update_trusted_list;
		
	$log->info("List of trusted hosts:");
	$log->info($_) foreach keys %TrustedHosts;
}

sub main
{
	eval {
		configure;
		
		start_server;
	};
	if ($@) {
		$log->logdie("Failed to start server: $@");
	}
	
	event_loop;
}

main;
