#!/usr/bin/perl
# brs_sequencer, Boone, 11/11/05
# Queue access to BRS/Search engine
#
# Modifications:
# 11/11/05 Boone      Initial coding
# 08/23/07 Boone      Don't die on failure of accept() -- might be too
#                     many queued searches causing too many open files,
#                     which will pass eventually; also send Q command
#                     to server if client dies
# 03/27/08 Boone      Argh!  Trying to find out why all the BRS users
#                     get locked
# 02/10/12 Boone      Screw it -- Run `brslock -clear` every time we hit
#                     zero active sessions
# End Modifications

# Libraries

	use Sys::Syslog;
	use Socket;
	use Fcntl;

# Initialize

	$lport = 5002;

	$lic = 2;

	$srvname = "localhost";
	$srvaddr = gethostbyname($srvname);
	$srvport = "5000";

	$debug = 1;

	$proto = getprotobyname("tcp");

	$rin = "\0" x 4;

	$nselbits = 32;

	$logpri = "LOG_INFO";
	openlog("brsseq", "pid,ndelay", "LOG_USER") ||
		die "unable to initialize syslog: $!";
	syslog($logpri, "starting");

	$SIG{PIPE} = 'IGNORE';

# Create listen socket

	socket($lsock, PF_INET, SOCK_STREAM, $proto) ||
	do
	{
		syslog($logpri, "unable to create listen socket: $!");
		die "unable to create listen socket: $!";
	};
	setsockopt($lsock, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) ||
	do
	{
		syslog($logpri, "unable to set listen socket options: $!");
		die "unable to set listen socket options: $!";
	};
	fcntl($lsock, &F_SETFL, (fcntl($lsock, &F_GETFL, 0) | O_NONBLOCK)) ||
	do
	{
		syslog($logpri, "unable to set listen socket nonblock: $!");
		die "unable to set listen socket nonblock";
	};
	$sainet = sockaddr_in($lport, INADDR_ANY);
	bind($lsock, $sainet) ||
	do
	{
		syslog($logpri, "unable to bind listen socket: $!");
		die "unable to bind listen socket: $!";
	};
	listen($lsock, 32) ||
	do
	{
		syslog($logpri, "unable to listen on listen socket: $!");
		die "unable to listen on listen socket: #!";
	};
	vec($rin, fileno($lsock), 1) = 1;
	syslog($logpri, "listening on socket %d", fileno($lsock));

# Main loop

	$sainet = sockaddr_in($srvport, $srvaddr);
	while (1)
	{
		if ($debug)
		{
#			syslog($logpri, "select watch bitmap %s", unpack("b32", $rin));
		}
		($nready, $timeleft) = select($rout = $rin, undef, undef, 5);
		if ($debug)
		{
#			syslog($logpri, "select result bitmap %s nready $nready error $!",
#				unpack("b32", $rin));
		}
		if ($nready < 0)
		{
			syslog($logpri, "select failed: $!");
			die "select failed: $!";
		}
		for ($i = 0; $i < $nselbits; $i++)
		{
			if (vec($rout, $i, 1) == 1)
			{
				if (fileno($lsock) == $i)
				{
					undef $ncsock;
					accept($ncsock, $lsock) ||
					do
					{
						syslog($logpri, "unable to accept connection: $!");
						warn "unable to accept connection: $!";
						next;
					};
					$hersockaddr    = getpeername($ncsock);
					($port, $iaddr) = sockaddr_in($hersockaddr);
					$herstraddr     = inet_ntoa($iaddr);
					syslog($logpri, "new connection from $herstraddr on " .
						"socket %d", fileno($ncsock));
					push(@queue, $ncsock);
				}
				elsif (defined($srv{$i}))
				{
					if ($debug)
					{
						syslog($logpri, "data from server on socket $i");
					}
					&copyout($i);
				}
				elsif (defined($cli{$i}))
				{
					if ($debug)
					{
						syslog($logpri, "data from client on socket $i");
					}
					&copyin($i);
				}
				else
				{
					syslog($logpri, "lost socket with fileno $i");
					die "lost socket with fileno $i";
				}
			}
		}

		while ((@queue > 0) && ($nactive < $lic))
		{
			undef $ssock;
			undef $csock;
			socket($ssock, PF_INET, SOCK_STREAM, $proto) ||
			do
			{
				syslog($logpri, "unable to create new server socket: $!");
				die "unable to create new server socket: $!";
			};
			connect($ssock, $sainet) ||
			do
			{
				syslog($logpri, "unable to connect new server socket: $!");
				die "unable to connect new socket: $!";
			};
			fcntl($ssock, &F_SETFL,
				(fcntl($ssock, &F_GETFL, 0) | O_NONBLOCK)) ||
			do
			{
				syslog($logpri, "unable to set new server socket nonblock: $!");
				die "unable to set new server socket nonblock";
			};
			$csock = shift(@queue);
			vec($rin, fileno($ssock), 1) = 1;
			vec($rin, fileno($csock), 1) = 1;
			$srv{fileno($ssock)} = $csock;
			$cli{fileno($csock)} = $ssock;
			$outq[fileno($ssock)] = "";
			$inq[fileno($csock)] = "";
			$nactive++;
			syslog($logpri, "created new server socket %d", fileno($ssock));
		}
	}

# Done

	exit(0);

###############################################################################
# Copy data from server to client
###############################################################################

	sub copyout
	{
		my $i = shift;
		my $rc;
		my $nc;
		my $buf;

		$rc = recv($cli{fileno($srv{$i})}, $buf, 512, 0);
		$nc = length($buf);
		if (! defined($rc))
		{
			syslog($logpri, "error $! reading from server $i");
			&serverclose($i);
		}
		elsif ($nc == 0)
		{
			syslog($logpri, "server $i closed connection");
			&serverclose($i);
			return;
		}
		elsif ($nc > 0)
		{
			$outq[$i] .= $buf;
			if ($debug)
			{
				syslog($logpri, "$nc chars from server $i to client %d",
					fileno($srv{$i}));
			}

			$nc = send($srv{$i}, $buf, 0);
			$outq[$i] = substr($outq[$i], $nc);
		}
	}

###############################################################################
# Copy data from client to server
###############################################################################

	sub copyin
	{
		my $i = shift;
		my $rc;
		my $nc;
		my $buf;

		$rc = recv($srv{fileno($cli{$i})}, $buf, 512, 0);
		$nc = length($buf);
		if (! defined($rc))
		{
			syslog($logpri, "error $! reading from client $i");
			&clientclose($i);
		}
		if ($nc == 0)
		{
			syslog($logpri, "client $i closed connection");
			&clientclose($i);
			return;
		}
		elsif ($nc > 0)
		{
			$inq[$i] .= $buf;
			if ($debug)
			{
				syslog($logpri, "$nc chars from client $i to server %d",
					fileno($cli{$i}));
			}

			$nc = send($cli{$i}, $buf, 0);
			$inq[$i] = substr($inq[$i], $nc);
		}
	}

###############################################################################
# Client closed, clean up
###############################################################################

	sub clientclose
	{
		my $i = shift;

		vec($rin, $i, 1) = 0;
		vec($rin, fileno($cli{$i}), 1) = 0;
		vec($rout, $i, 1) = 0;
		vec($rout, fileno($cli{$i}), 1) = 0;
		send($cli{$i}, "\n", 0);
		send($cli{$i}, "Q\n", 0);
		close($srv{fileno($cli{$i})}) ||
			syslog($logpri, "unable to close client side in clientclose: $!"); # client
		undef($srv{fileno($cli{$i})}); # client
		close($cli{$i}) ||
			syslog($logpri, "unable to close server side in clientclose: $!"); # server
		undef($cli{$i}); # server
		$nactive--;
		if (! $nactive)
		{
			system("/usr/local/brs/Bin/brslock -clear");
		}
		return;
	}

###############################################################################
# Server closed, clean up
###############################################################################

	sub serverclose
	{
		my $i = shift;

		vec($rin, $i, 1) = 0;
		vec($rin, fileno($srv{$i}), 1) = 0;
		vec($rout, $i, 1) = 0;
		vec($rout, fileno($srv{$i}), 1) = 0;
		close($cli{fileno($srv{$i})}) ||
			syslog($logpri, "unable to close server side in serverclose: $!"); # server
		undef($cli{fileno($srv{$i})}); # server
		close($srv{$i}) ||
			syslog($logpri, "unable to close client side in serverclose: $!"); # client
		undef($srv{$i}); # client
		$nactive--;
		if (! $nactive)
		{
			system("/usr/local/brs/Bin/brslock -clear");
		}
	}
