#!/usr/bin/perl
use strict;

use POSIX;
use IO::Socket;
use IO::Select;
use Socket;
use Fcntl;
use Carp;

use vars qw{$sourcedir $dbdir $daemon $dodumps $nextdump $syslog $port
	$dumpinterval $numbackups $pidfile};
$dbdir="./db";
$port=7777;
$dumpinterval=30;
$numbackups=2;
$sourcedir='.';

# Source config file.
foreach ('./',$ENV{HOME}.'/.','/usr/local/etc/','/etc/') {
	if (-e "${_}perlmoo.conf") { do "${_}perlmoo.conf" ; last }
}

# Parse command line.
use Getopt::Long;
GetOptions(
	"port|p=i" => \$port,
	"dbdir|d=s" => \$dbdir,
	"sourcedir|s=s" => \$sourcedir,
	"help|h" => \&CommandLineHelp,
	"syslog" => \$syslog,
	"daemon" => \$daemon,
	"interval|i=i" => \$dumpinterval,
	"backup|b=i" => \$numbackups,
	"pidfile|P=s" => \$pidfile,
) || CommandLineHelp();

$syslog=1 if $daemon;
push @INC,$sourcedir if $sourcedir;
require Utils;
Utils::LogToSyslog() if $syslog;

if ($daemon) {
	exit if fork;
	POSIX::setsid() || Utils::Log("notice","Can't start a new session: $!");
}

if ($pidfile) {
	open (PID,">$pidfile") || Utils::Log("notice","Can't write to pid file: $!");
	print PID "$$\n";
	close PID;
}

# Only now do we want to set this up.
eval '
	END {
		Utils::Log("info","Exiting.");
	}
';

# Require not use, because this needs to come after argument processing.
# We need to pull in all the modules before we chroot.
require Db;
require ThingList;
require Programmer;
require LoginPerson;
require Error;
require Room;
require GuestAllocator;
require LoginRoom;
require Exit;
require Wizard;
require HelpObject;

# Set up the tcp server. Must do this before chroot.
my $server= IO::Socket::INET->new(
	LocalPort => $port,
	Proto => 'tcp',
	Listen => 10,
	Reuse => 1,
) or (Utils::Log("notice","Cannot connect to socket $port: $@\n") && exit 1);
Utils::Log("info","Connected to port $port.");

# Now change into the dbdir, for the chroot that follows.
chdir($dbdir);

# For security, do a chroot.
use Cwd;
if (chroot(getcwd)) {
	Utils::Log("info","Chrooted to $dbdir.");
}	
else {
	Utils::Log("notice","SECURITY PROBLEM: Unable to chroot: $!.");
}	

# Figure out what user and group owns the db file, and change to them.
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 $atime,$mtime,$ctime,$blksize,$blocks) = stat("db.pl");
$(=$gid;
$)="$gid $gid";
$>=$<=$uid;
if ($> != $uid || $< != $uid || $( != $gid || $) != $gid) {
	Utils::Log("notice","SECURITY PROBLEM: Unable to set user perms. Currently: euid: $> uid: $< egids: $) gids: $(.");
}
else {
	Utils::Log("info","Running as uid $uid, gid $gid.");
}
if ($> == 0 || $) == 0) {
	Utils::Log("notice","SECURITY PROBLEM: Running as user or group root! Eep!");
}

# Db load.
Utils::Log("info","Initializing world..");
my $ret=Db::LoadFromFile("db.pl");
if (Error::iserror($ret)) {
	Utils::Log("notice",$ret->message);
	exit 1;
}
if (! Db::TestVersion()) {
	Utils::Log("notice","Cannot load old format database - run dbconvert on your database.");
	exit 1;
}

$SIG{CHLD}='IGNORE';
# These sigpipes can crash the program otherwise.
$SIG{PIPE}=sub { Utils::Log("notice","got a sigpipe") };
# Make sure we dump the db on various signals.
$SIG{USR1}=sub {Db::DumpDb("SIG".(shift),$numbackups)};
# Do non-forking dumps for these signals.
$SIG{QUIT}=sub {Db::DumpDb("SIG".(shift),$numbackups,undef,1); exit};
$SIG{TERM}=sub {Db::DumpDb("SIG".(shift),$numbackups,undef,1); exit};
$SIG{INT}=sub {	Db::DumpDb("SIG".(shift),$numbackups,undef,1); exit};
# Catch die, and attempt to recover. The db might be messed up, though.
$SIG{__DIE__}=sub {
	# Don't try to do this if we were in an eval - that's not fatal
	# anyway.
	if ($^S eq undef && defined($^S)) {
		my $reason=shift;
		chomp $reason;
		Db::DumpDb("Dying because: $reason - please report this bug to joey\@kitenet.net",$numbackups,"db-postmortem.pl");
		Carp::cluck("Dying on error");
	}
};

my %inbuffer=();
my %outbuffer=();
my %ready=();
my %people=();
NonBlock($server);
my $select=IO::Select->new($server);
my %people=();

if ($dumpinterval > 0) {
	$nextdump=time() + ($dumpinterval * 60);
	$dodumps=1;
}	

# Main loop.
Utils::Log("info","Setup complete, accepting connections.");
while (1) {
	my $client;
	my $rv;
	my $data;
	
	# See if clients have sent any data.
	foreach $client ($select->can_read(1)) {
		if ($client == $server) {
			# New connection.
			my($iaddr, $address, $port, $peer_host);
			$client=$server->accept;
			if(!$client){
				Utils::Log("notice","Problem with accept(): $!");
				next;
			}	
			($port,$iaddr)=sockaddr_in(getpeername($client));
			$peer_host = gethostbyaddr($iaddr, AF_INET) || inet_ntoa($iaddr);
			$select->add($client);
			NonBlock($client);

			# Set up a LoginPerson for this connection so the
			# user can auth themselves.
			Utils::SuWizard();
			$people{$client}=LoginPerson->new(name => $peer_host);
			# Note use of closures to preserve $client when subs are called.
			$people{$client}->owner($people{$client});
			$people{$client}->output_callback(sub { OutputCallBack($client,@_) } );
			$people{$client}->close_callback(sub { CloseCallBack($client) } );
			$people{$client}->handle($client);
			$people{$client}->host($peer_host);
	
			# FIXME: notice I add them to the room, but don't let the
			# room know they've moved into it. This prevents the room
			# from showing other people logging into it. A better
			# way would be to use a dark room, once implmented.
			$people{$client}->location(ThingList::FindByType("LoginRoom"));
			ActiveUser::setactive($people{$client});
		
			Utils::Log("info","#".$people{$client}->id.": New connection from $peer_host port $port.");
		}
		else {
			# Read data from client.
			$data='';
			$rv=$client->recv($data,POSIX::BUFSIZ, 0);
			
			unless (defined $rv && length $data) {
				# EOF from client.
				KillClient($client,'eof');
				next;
			}
			
			$inbuffer{$client}.=$data;
			
			# Do we have a full line of data?
			while ($inbuffer{$client}=~s/(.*\n)//) {
				push @{$ready{$client}},$1;
			}
		}
	}
	
	# Process data from clients. Only allow each client to do one command
	# even if they have queued up a lot - this prevents flooding problems.
	my $request;
	foreach $client (keys %ready) {
		ActiveUser::setactive($people{$client});
		if (ref($ready{$client}) eq 'ARRAY' && @{$ready{$client}}) {
			$request=shift(@{$ready{$client}});
			$people{$client}->tell($people{$client}->parse($request));
		}
	}
	
	# See if we have buffers to flush.
	foreach $client ($select->can_write(1)) {
		next unless $outbuffer{$client}; # nothing to say?
		
		$rv=$client->send($outbuffer{$client},0);
		unless (defined $rv) {
			warn "Unable to write to $client\n";
			next;
		}
		if ($rv == length $outbuffer{$client} ||
		    $! == POSIX::EWOULDBLOCK) {
			substr($outbuffer{$client},0,$rv)='';
			delete $outbuffer{$client} unless length $outbuffer{$client};
		}
		else {
			# Couldn't write out all data, client isn't there anymore.
			KillClient($client, 'write failure');
			next;
		}
	}

	# Check if it's time to dump the database.
	if (time() >= $nextdump && $dodumps > 0) {
		$nextdump=time() + ($dumpinterval * 60);
		Db::DumpDb("$dumpinterval minute dump",$numbackups);
	}
}

# Set a socket into nonblocking mode.
sub NonBlock {
	my $socket=shift;
	my $flags= fcntl($socket, F_GETFL, 0) 
		or die "Can't get flags for socket: $!\n";
	fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
		or die "Can't make socket nonblocking: $!\n";
}

# Someone disconnected.
sub KillClient {
	my $client=shift;
	my $reason=shift; # optional, why did we close it?
	
	$reason=": $reason" if $reason;
	Utils::Log("info","Removing ".$people{$client}->name." (#".$people{$client}->id.")$reason");

	# Remove their object from the moo.
	ActiveUser::setactive($people{$client});
	$people{$client}->logout;
	delete $people{$client};

	delete $inbuffer{$client};
	delete $outbuffer{$client};
	delete $ready{$client};
	$select->remove($client);
	close $client;
}

# Pass this the current object being used for a client, and the new one,
# and it will make the new object be used.
sub ChangeClientObject {
	my $old=shift;
	my $new=shift;
	
	my $key;
	foreach $key (keys %people) {
		if ($people{$key} == $old) {
			$people{$key}=$new;
			Utils::SuWizard();
			Utils::Log("info","#".$old->id.": Login as ".$new->name." (#".$new->id.").");
		}
	}
}

# This function is called by a Person object when data is sent to it.
# It just stores that data in %outbuffer to be dealt with later.
sub OutputCallBack {
	my $client=shift;
	$outbuffer{$client}.=join('',@_);
}

# This is called when a Person object wants to close its i/o channel.
sub CloseCallBack {
	my $client=shift;

	# First, flush all pending output, if we can.
	$client->send($outbuffer{$client},0);

	delete $inbuffer{$client};
	delete $outbuffer{$client};
	delete $ready{$client};
	$select->remove($client);
	close($client);
	
	Utils::Log("info","Logging out ".$people{$client}->name." (#".$people{$client}->id.").");
}

sub CommandLineHelp {
	print <<"	eof";
Usage: perlmoo [options ...]
  -p port, --port=port     Make the moo listen to the specified port number.
                           Default is $port
  -d dir, --dbdir=dir	   Dump database files to the specified directory.
                           Default is "$dbdir"
  -s dir, --sourcedir=dir  Look for perlmoo source files in the specified
                           directory.
		 	   Default is "$sourcedir"
          --syslog         Log to the syslog.
 	  --daemon         Fork into the background and run as a daemon.
	                   Enables --syslog automatically.
  -i num,  --interval=num  Dump out the database every num minutes. Default
                           is $dumpinterval, set to 0 to disable dumps completly.
  -b num, --backup=num	   Keep num backups of the database. Default is $numbackups.
  -P file,--pidfile=file   Write out pid to the specified file. 
  -h,     --help           Display this help.
	eof
	exit 1;
}
