#!/usr/bin/env perl

# Auto IRC Bot. An advanced, lightweight and powerful IRC bot.
# Copyright (C) 2010-2011 Xelhua Development Team (doc/CREDITS)
# This program is free software; rights to this code are stated in doc/LICENSE.
package Auto;
require 5.010000;
use strict;
use warnings;
use POSIX;
use locale;
use English qw(-no_match_vars);
use feature qw(switch);
use Sys::Hostname;
use IO::Socket;
use IO::Select;
use Class::Unload;
use FindBin qw($Bin);
our $Bin = $Bin; ## no critic qw(NamingConventions::Capitalization Variables::ProhibitPackageVars)
BEGIN {
    unshift @INC, "$Bin/../src";

    # Set version information.
    use constant { ## no critic qw(ValuesAndExpressions::ProhibitConstantPragma)
	    NAME   => 'Auto IRC Bot',
	    VER    => 3,
	    SVER   => 0,
	    REV    => 0,
	    RSTAGE => 'd',
        GR     => substr `cat $Bin/../.git/refs/heads/indev`, 0, 7
    };
}
use API::Std qw(conf_get err);
use API::Log qw(println alog dbug);
use DB::Flatfile;
use Parser::Config;
use Parser::Lang;
use Parser::IRC;
use Core::IRC;


our $VERSION = 3.0.0;
local $PROGRAM_NAME = 'auto';

# Check for build files.
if (!-e "$Bin/../build/os" or !-e "$Bin/../build/perl" or !-e "$Bin/../build/time" or !-e "$Bin/../build/ver") {
	println 'Missing build file(s). Please build Auto before running it.' and exit;
}

# Check build OS.
open my $BFOS, '<', "$Bin/../build/os" or println 'Cannot start: Broken build.' and exit;
my @BFOS = <$BFOS>;
close $BFOS or println 'Cannot start: Broken build.' and exit;
if ($BFOS[0] ne $OSNAME."\n") {
	println 'Cannot start: Broken build.' and exit;
}
undef @BFOS;

# Check build features.
our $ENFEAT;
open my $BFFEAT, '<', "$Bin/../build/feat" or println 'Cannot start: Broken build.' and exit;
my @BFFEAT = <$BFFEAT>;
close $BFFEAT or println 'Cannot start: Broken build.' and exit;
$ENFEAT = substr $BFFEAT[0], 0, length($BFFEAT[0]) - 1;
undef @BFFEAT;

# Check build Perl version.
open my $BFPERL, '<', "$Bin/../build/perl" or println 'Cannot start: Broken build.' and exit;
my @BFPERL = <$BFPERL>;
close $BFPERL or println 'Cannot start: Broken build.' and exit;
if ($BFPERL[0] ne $]."\n") {
	println 'Cannot start: Broken build.' and exit;
}
undef @BFPERL;

# Check build Auto version.
open my $BFVER, '<', "$Bin/../build/ver" or println 'Cannot start: Broken build.' and exit;
my @BFVER = <$BFVER>;
close $BFVER or println 'Cannot start: Broken build.' and exit;
if ($BFVER[0] ne VER.q{.}.SVER.q{.}.REV.RSTAGE."\n") {
	println 'Cannot start: Broken build.' and exit;
}
undef @BFVER;

# Set signal handlers.
local $SIG{TERM}       = \&signal_term;
local $SIG{INT}        = \&signal_int;
local $SIG{HUP}        = \&signal_hup;
local $SIG{'__WARN__'} = \&signal_perlwarn;
local $SIG{'__DIE__'}  = \&signal_perldie;
API::Std::event_add('on_sigterm');
API::Std::event_add('on_sigint');
API::Std::event_add('on_sighup');


# Print startup message.
println <<'EOF';
8""""8                  
8    8 e   e eeeee eeeee
8eeee8 8   8   8   8  88
88   8 8e  8   8e  8   8
88   8 88  8   88  8   8
88   8 88ee8   88  8eee8
EOF
println '* '.NAME.' (version '.VER.q{.}.SVER.q{.}.REV.RSTAGE.') is starting up...';

our ($APID, %TIMERS);

# Get arguments.
our $DEBUG = 0;
our $NUC = 0;
if (defined $ARGV[0]) {
	foreach (@ARGV) {
		given ($_) {
            when ('-d') { $DEBUG = 1; }
            when ('-nuc') { $NUC = 1; }
        }
    }
}

# Check for updates.
if (!$NUC and RSTAGE ne 'd') {
    println '* Connecting to update server...';
    my $uss = IO::Socket::INET->new(
        'Proto'    => 'tcp',
        'PeerAddr' => 'dist.xelhua.org',
        'PeerPort' => 80,
        'Timeout'  => 30
    ) or err(1, 'Cannot connect to update server! Aborting update check.');
    send $uss, "GET http://dist.xelhua.org/auto/version.txt\n", 0;
    my $dll = q{};
    while (my $data = readline $uss) {
        $data =~ s/(\n|\r)//g;
        my ($v, $c) = split m/[=]/, $data;

        if ($v eq 'url') {
            $dll = $c;
        }
        elsif ($v eq 'version') {
            if (VER.q{.}.SVER.q{.}.REV.RSTAGE ne $c) {
                println('!!! NOTICE !!! Your copy of Auto is outdated. Current version: '.VER.q{.}.SVER.q{.}.REV.RSTAGE.' - Latest version: '.$c);
                println('!!! NOTICE !!! You can get the latest Auto by downloading '.$dll);
            }
            else {
                println('* Auto is up-to-date.');
            }
        }
    }
}

# Include IPv6 if Auto was built for it.
if ($ENFEAT =~ /ipv6/) { require IO::Socket::INET6; }
# Include SSL if Auto was built for it.
if ($ENFEAT =~ /ssl/) { require IO::Socket::SSL; }

# Parse configuration file.
println '* Parsing configuration file auto.conf...';
our $CONF = Parser::Config->new('auto.conf') or err(1, 'Failed to parse configuration file!', 1);
our %SETTINGS = $CONF->parse or err(1, 'Failed to parse configuration file!', 1);
println ' Success';

if (conf_get('die')) {
	if ((conf_get('die'))[0][0] == 1) {
		println '!!! You didn\'t read the whole config.';
		println '!!! Insert new user then try again.';
		exit;
	}
}

# Check for required configuration values.
my @REQCVALS = qw(locale expire_logs server fantasy_pf);
foreach my $REQCVAL (@REQCVALS) {
	if (!conf_get($REQCVAL)) {
		my $err = 2;
		if ($REQCVAL eq 'expire_logs') {
			$err = 1;
		}
		err($err, "Missing required configuration value: $REQCVAL", 1);
	}
}
undef @REQCVALS;

# Parse translations.
println '* Parsing translation files...';
our $LOCALE = (conf_get('locale'))[0][0];
my @lang = split m/[_]/, $LOCALE;
Parser::Lang::parse($lang[0]) or err(2, 'Failed to parse translation files!', 1);
undef @lang;
println ' Success';

# Expire old logs.
API::Log::expire_logs();

# Load database.
DB::load();

# Parse privileges.
our (%PRIVILEGES);
# If there are any privsets.
if (conf_get('privset')) {
	# Get them.
	my %tcprivs = conf_get('privset');

    foreach my $tckpriv (keys %tcprivs) {
		# For each privset, get the inner values.
		my %mcprivs = conf_get("privset:$tckpriv");

        # Iterate through them.
		foreach my $mckpriv (keys %mcprivs) {
			# Switch statement for the values.
			given ($mckpriv) {
				# If it's 'priv', save it as a privilege.
				when ('priv') {
					if (defined $PRIVILEGES{$tckpriv}) {
						# If this privset exists, push to it.
						push @{ $PRIVILEGES{$tckpriv} }, ($mcprivs{$mckpriv})[0][0];
					}
					else {
						# Otherwise, create it.
						@{ $PRIVILEGES{$tckpriv} } = (($mcprivs{$mckpriv})[0][0]);
					}
				}
				# If it's 'inherit', inherit the privileges of another privset.
				when ('inherit') {
					# If the privset we're inheriting exists, continue.
					if (defined $PRIVILEGES{($mcprivs{$mckpriv})[0][0]}) {
						# Iterate through each privilege.
						foreach (@{ $PRIVILEGES{($mcprivs{$mckpriv})[0][0]} }) {
							# And save them to the privset inheriting them
							if (defined $PRIVILEGES{$tckpriv}) {
								# If this privset exists, push to it.
								push @{ $PRIVILEGES{$tckpriv} }, $_;
							}
							else {
								# Otherwise, create it.
								@{ $PRIVILEGES{$tckpriv} } = ($_);
							}
						}
					}
				}
			}
		}
	}
}

# Successful startup.
our $STARTTIME = time;
println '* Auto successfully started at '.POSIX::strftime('%Y-%m-%d %I:%M:%S %p', localtime).q{.};
alog 'Auto successfully started.';

# Fork into the background if not in debug mode.
if (!$DEBUG) {
    println '*** Becoming a daemon...';
    open STDIN, '<', '/dev/null' or err(2, "Can't read /dev/null: $ERRNO", 1);
    open STDOUT, '>>', '/dev/null' or err(2, "Can't write to /dev/null: $ERRNO", 1);
    open STDERR, '>>', '/dev/null' or err(2, "Can't write to /dev/null: $ERRNO", 1);
    $APID = fork;
    if ($APID != 0) {
        alog '* Successfully forked into the background. Process ID: '.$APID;
        if (!-e "$Bin/auto.pid") {
			system "touch $Bin/auto.pid";
		}
		open my $FPID, '>', "$Bin/auto.pid" or exit;
		print {$FPID} "$APID\n" or exit;
		close $FPID or exit;
        exit;
    }
    POSIX::setsid() or err(2, "Can't start a new session: $ERRNO", 1);
}
else {
    $APID = $PID;
}

# Events.
API::Std::event_add('on_preconnect');

# Load modules.
if (conf_get('module')) {
	alog '* Loading modules...';
	dbug '* Loading modules...';
	foreach (@{ (conf_get('module'))[0] }) {
		mod_load($_);
	}
}

## Create sockets.
alog '* Connecting to servers...';
dbug '* Connecting to servers...';
# Get servers from config.
my %cservers = conf_get('server');
# Set the hashes and processes hashes.
our (%SOCKET, $SELECT);
$SELECT = IO::Select->new();
my $it = 0;
# Iterate through each configured server.
foreach my $cskey (keys %cservers) {
    # Prepare socket data.
    my %conndata = (
		Proto => 'tcp',
    	LocalAddr => $cservers{$cskey}{'bind'}[0],
		PeerAddr  => $cservers{$cskey}{'host'}[0],
		PeerPort  => $cservers{$cskey}{'port'}[0],
        Timeout   => 20,
    );
	# Set IPv6/SSL data.
    my $use6 = 0;
    my $usessl = 0;
    if (defined $cservers{$cskey}{'ipv6'}[0]) { $use6 = $cservers{$cskey}{'ipv6'}[0]; }
    if (defined $cservers{$cskey}{'ssl'}[0]) { $usessl = $cservers{$cskey}{'ssl'}[0]; }

    # CertFP.
    if ($usessl) {
        if (defined $cservers{$cskey}{'certfp'}[0]) {
            if ($cservers{$cskey}{'certfp'}[0] eq 1) {
                $conndata{'SSL_use_cert'} = 1;
                if (defined $cservers{$cskey}{'certfp_cert'}[0]) {
                    $conndata{'SSL_cert_file'} = "$Bin/../etc/".$cservers{$cskey}{'certfp_cert'}[0];
                }
                if (defined $cservers{$cskey}{'certfp_key'}[0]) {
                    $conndata{'SSL_key_file'} = "$Bin/../etc/".$cservers{$cskey}{'certfp_key'}[0];
                }
                if (defined $cservers{$cskey}{'certfp_pass'}[0]) {
                    $conndata{'SSL_passwd_cb'} = sub { return $cservers{$cskey}{'certfp_pass'}[0]; };
                }
            }
        }
    }           

    # Create the socket.
    if ($use6) {
	    $SOCKET{$cskey} = IO::Socket::INET6->new(%conndata) or # Or error.
        err(2, 'Failed to connect to server ('.$ERRNO.'): '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0) 
        and delete $SOCKET{$cskey} and next;
    }
    else {
        if ($usessl) {
	        $SOCKET{$cskey} = IO::Socket::SSL->new(%conndata) or # Or error.
            err(2, 'Failed to connect to server ('.$ERRNO.'): '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0) 
            and delete $SOCKET{$cskey} and next;
        }
        else {
	        $SOCKET{$cskey} = IO::Socket::INET->new(%conndata) or # Or error.
            err(2, 'Failed to connect to server ('.$ERRNO.'): '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0) 
            and delete $SOCKET{$cskey} and next;
        }
    }

    # Send PASS if we have one.
	if (defined $cservers{$cskey}{'pass'}[0]) {
		socksnd($cskey, 'PASS :'.$cservers{$cskey}{'pass'}[0]) or
			err(2, 'Failed to connect to server: '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
			and next;
	}
	API::Std::event_run('on_preconnect', $cskey);
	# Send NICK/USER.
	API::IRC::nick($cskey, $cservers{$cskey}{'nick'}[0]);
	socksnd($cskey, 'USER '.$cservers{$cskey}{'ident'}[0].' '.hostname.' '.$cservers{$cskey}{'host'}[0].' :'.$cservers{$cskey}{'realname'}[0]) or
		err(2, 'Failed to connect to server: '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
		and next;
	# Add to select.
	$SELECT->add($SOCKET{$cskey});
	# Success!
	alog '** Successfully connected to server: '.$cskey;
	dbug '** Successfully connected to server: '.$cskey;
	$it = 1;
}

# Success!
if ($it) {
	alog '** Success: Connected to server(s).';
	dbug '** Success: Connected to server(s).';
}
else {
	err(2, 'No server connections.', 1);
}
undef $it;

# Create core hooks.
API::Std::hook_add('on_uprivmsg', 'ctcp_version_reply', \&Core::IRC::version_reply);
# Create core commands.
API::Std::cmd_add('MODLOAD', 1, 'cfunc.modules', \%Core::IRC::HELP_MODLOAD, \&Core::IRC::cmd_modload);
API::Std::cmd_add('MODUNLOAD', 1, 'cfunc.modules', \%Core::IRC::HELP_MODUNLOAD, \&Core::IRC::cmd_modunload);
API::Std::cmd_add('MODRELOAD', 1, 'cfunc.modules', \%Core::IRC::HELP_MODRELOAD, \&Core::IRC::cmd_modreload);
API::Std::cmd_add('SHUTDOWN', 2, 'cmd.shutdown', \%Core::IRC::HELP_SHUTDOWN, \&Core::IRC::cmd_shutdown);
API::Std::cmd_add('RESTART', 2, 'cmd.restart', \%Core::IRC::HELP_RESTART, \&Core::IRC::cmd_restart);
API::Std::cmd_add('HELP', 2, 0, \%Core::IRC::HELP_HELP, \&Core::IRC::cmd_help);

# Infinite while loop.
while (1) {
	# Timer check.
	foreach my $tk (keys %TIMERS) {
		if ($TIMERS{$tk}{time} <= time) {
			&{ $TIMERS{$tk}{sub} }();
			if ($TIMERS{$tk}{type} == 1) {
				# If it's type 1, delete from memory.
				delete $TIMERS{$tk};
			}
			elsif ($TIMERS{$tk}{type} == 2) {
				# If it's type 2, reset timer.
				$TIMERS{$tk}{time} = time + $TIMERS{$tk}{secs};
			}
			else {
				# This should never happen.
				delete $TIMERS{$tk};
			}
		}
	}
	# Socket check.
	foreach my $sock ($SELECT->can_read(1)) {
		# Figure out what network is sending us data.
		my $sockid;
		foreach (keys %SOCKET) {
			if ($SOCKET{$_} eq $sock) { $sockid = $_; }
		}
		# Read the data.
		my $idata;
		sysread $sock, $idata, POSIX::BUFSIZ, 0;

		# Check for the data.
		if (!defined $idata || length($idata) == 0) {
			# Got EOF, close socket
			err(2, "Lost connection to $sockid!", 0);
			$SELECT->remove($sock);
            delete $SOCKET{$sockid};
            next;
		}

        # Read the buffer.
		my $data .= $idata;
		while ($data =~ s/(.*\n)//) {
			my $line = $1;

            # Remove the newlines.
			chomp $line;
			# Debug.
			dbug $sockid.' >> '.$line;

            # Parse data.
			Parser::IRC::ircparse($sockid, $line);
		}
	}
}

###############
# Subroutines #
###############

# Send data to socket.
sub socksnd
{
	my ($svr, $data) = @_;

    if (defined $SOCKET{$svr}) {
		syswrite $SOCKET{$svr}, $data."\n", POSIX::BUFSIZ, 0;
		dbug "$svr << $data";
		return 1;
	}
	else {
		return 0;
	}
}

# Load a module.
sub mod_load {
    my ($module) = @_;

    if (-e "$Bin/../modules/$module.pm") {
        do "$Bin/../modules/$module.pm" and return 1;
    }

    return 0;
}


## Signal handlers

# SIGTERM
sub signal_term
{
	API::Std::event_run('on_sigterm');
	foreach (keys %SOCKET) { API::IRC::quit($_, 'Caught SIGTERM'); }
	DB::flush();
	dbug '!!! Caught SIGTERM; terminating...';
	alog '!!! Caught SIGTERM; terminating...';
	if (-e "$Bin/auto.pid") {
		unlink "$Bin/auto.pid";
	}
	sleep 1;
	exit;
}

# SIGINT
sub signal_int
{
	API::Std::event_run('on_sigint');
	foreach (keys %SOCKET) { API::IRC::quit($_, 'Caught SIGINT'); }
	DB::flush();
	dbug '!!! Caught SIGINT; terminating...';
	alog '!!! Caught SIGINT; terminating...';
	if (-e "$Bin/auto.pid") {
		unlink "$Bin/auto.pid";
	}
	sleep 1;
	exit;
}

# SIGHUP
sub signal_hup
{
	API::Std::event_run('on_sighup');
	dbug '!!! Caught SIGHUP but rehash is unavailable; ignoring';
	alog '!!! Caught SIGHUP but rehash is unavailable; ignoring';
	return 1;
}

# __WARN__
sub signal_perlwarn
{
    my ($warnmsg) = @_;
    $warnmsg =~ s/(\n|\r)//xsmg;
    alog 'Perl Warning: '.$warnmsg;
    if ($DEBUG) { println 'Perl Warning: '.$warnmsg; }
    return 1;
}

# __DIE__
sub signal_perldie
{
    my ($diemsg) = @_;
    $diemsg =~ s/(\n|\r)//xsmg;

    return if $EXCEPTIONS_BEING_CAUGHT;
    alog 'Perl Fatal: '.$diemsg.' -- Terminating program!';
	foreach (keys %SOCKET) { API::IRC::quit($_, 'A fatal error occurred!'); }
    DB::flush();
	if (-e "$Bin/auto.pid") {
		unlink "$Bin/auto.pid";
	}
	sleep 1;
    println 'FATAL: '.$diemsg;
    exit;
}

# vim: set ai sw=4 ts=4: