#!/usr/bin/perl

# The Veachian Internet Relay Chat Daemon - Coded by Jahn Veach/Veachian64 - V64@V64.net - http://www.v64.net/

# This code is in the public domain. It is provided as is. You may use it for any purpose you want.
# The author is not responsible for any damages caused by this program.

use strict;
use warnings;

use IO::Select;
use IO::Socket;
use Socket;

# TODO: Modularize code.
#       No subroutines fiddle around with globals (too much)
#       Constants ($local{} and the like) in sprintfs.


# Some initialization:

###############################################################################
# We're just gonna get this out of the way right now.
# These define all the server numerics and string formats.
#
# Note: Numeric 462 was originally ERR_ALREADYREGISTRED (not REGISTERED).
# Why this legacy typo has stayed in for so long is beyond me.
# I'm taking it out.
###############################################################################
my $RPL_WELCOME           = 001;
my $RPL_YOURHOST          = 002;
my $RPL_CREATED           = 003;
my $RPL_LUSERCLIENT       = 251;
my $RPL_LUSEROP           = 252;
my $RPL_LUSERUNKNOWN      = 253;
my $RPL_LUSERCHANNELS     = 254;
my $RPL_LUSERME           = 255;
my $RPL_LOCALUSERS        = 265;
my $RPL_GLOBALUSERS       = 266;
my $RPL_WHOISUSER         = 311;
my $RPL_WHOISSERVER       = 312;
my $RPL_ENDOFWHOIS        = 318;
my $RPL_MOTD              = 372;
my $RPL_MOTDSTART         = 375;
my $RPL_ENDOFMOTD         = 376;
my $ERR_NOSUCHNICK        = 401;
my $ERR_NOTEXTTOSEND      = 412;
my $ERR_UNKNOWNCOMMAND    = 421;
my $ERR_NOMOTD            = 422;
my $ERR_NONICKNAMEGIVEN   = 431;
my $ERR_ERRONEUSNICKNAME  = 432;
my $ERR_NICKNAMEINUSE     = 433;
my $ERR_NOTREGISTERED     = 451;
my $ERR_NEEDMOREPARAMS    = 461;
my $ERR_ALREADYREGISTERED = 462;

my %numstr;

$numstr{$RPL_WELCOME} = ':Welcome to the %s IRC Network %s!%s@%s';
$numstr{$RPL_YOURHOST} = ':Your host is %s, running version %s';
$numstr{$RPL_CREATED} = ':This server was created %s';
$numstr{$RPL_LUSERCLIENT} = ':There are %s users and %s invisible on %s servers';
$numstr{$RPL_LUSEROP} = '%s :operator(s) online';
$numstr{$RPL_LUSERUNKNOWN} = '0 :unknown connection(s)';
$numstr{$RPL_LUSERCHANNELS} = '%s :channels formed';
$numstr{$RPL_LUSERME} = ':I have %s clients and %s servers';
$numstr{$RPL_LOCALUSERS} = ':Current Local Users: %s  Max: %s';
$numstr{$RPL_GLOBALUSERS} = ':Current Global Users: %s  Max: %s';
$numstr{$RPL_WHOISUSER} = '%s %s %s * %s';
$numstr{$RPL_WHOISSERVER} = '%s %s :%s';
$numstr{$RPL_ENDOFWHOIS} = '%s :End of /WHOIS list.';
$numstr{$RPL_MOTD} = ':- %s';
$numstr{$RPL_MOTDSTART} = ':- %s Message of the Day -';
$numstr{$RPL_ENDOFMOTD} = ':End of /MOTD command.';
$numstr{$ERR_NOSUCHNICK} = '%s :No such nick';
$numstr{$ERR_NOTEXTTOSEND} = ':No text to send';
$numstr{$ERR_UNKNOWNCOMMAND} = '%s :Unknown command or command not yet implemented';
$numstr{$ERR_NOMOTD} = ':MOTD File is missing';
$numstr{$ERR_NONICKNAMEGIVEN} = ':No nickname given';
$numstr{$ERR_ERRONEUSNICKNAME} = '%s :Erroneus Nickname: %s';
$numstr{$ERR_NICKNAMEINUSE} = '%s :Nickname is already in use.';
$numstr{$ERR_NOTREGISTERED} = '%s :Register first';
$numstr{$ERR_NEEDMOREPARAMS} = '%s :Not enough parameters';
$numstr{$ERR_ALREADYREGISTERED} = ':You may not reregister';

my %commhash;

$commhash{user}    = \&serv_user;
$commhash{nick}    = \&serv_nick;
$commhash{privmsg} = \&serv_privmsg;
$commhash{whois}   = \&serv_whois;
$commhash{lusers}  = \&serv_lusers;
$commhash{motd}    = \&serv_motd;
$commhash{notice}  = \&serv_privmsg;
$commhash{online}  = \&serv_online;
###############################################################################

my @clients_to_connect; # Array containing a list of filehandles that just connected.

my %users;  # Hash containing filehandles as keys, references to hashes as values. Hashes contain user info.
my %local;  # Hash containing all local info for the server. Ex. $local{users}

# Will be replaced to be read from a config file later.
$local{version}     = 'Veachian-0.23';
$local{network}     = 'V64net';
$local{server}      = 'irc.V64.net';
$local{server_desc} = 'The Veachian IRCd - Written entirely in the Perl programming language.';
$local{start_date}  =  get_date();
$local{motd_file}   = 'vircd.motd';
$local{port}        = 4242;
$local{read_size}   = 1_048_576;

my $debug = 0;

$local{users} = 0;
$local{record_users} = 0;
$local{invisible_users} = 0;
$local{non_invisible_users} = 0;
$local{servers} = 1;
$local{operators} = 0;
$local{channels} = 0;

print "Starting $local{version}......";

$local{listen} =
    IO::Socket::INET->new(
        LocalPort => $local{port},
        Listen    => 10,
        Proto     => 'tcp',
        Reuse     => 1
    )
or die "Unable to creating listening socket: $!\n";

$local{reader} = IO::Select->new();
$local{reader}->add($local{listen});
$local{sender} = IO::Select->new();
$local{sender}->add($local{listen});

print "Server running.\n";

while (1) {
    my @queues = IO::Select->select($local{reader}, $local{sender}, undef, 0.1);
    my @clients_to_disconnect; # Array containing a list of filehandles that have disconnected.

    foreach my $fh (@{ $queues[1] }) {
        my $write = syswrite($fh, $users{$fh}->{recv_buf});
        if ($users{$fh}->{nick} && $debug) { print "Sending to $users{$fh}->{hostname} ($users{$fh}->{nick}): $users{$fh}->{recv_buf}\n" }
        elsif ($debug) { print "Sending to $users{$fh}->{hostname}: $users{$fh}->{recv_buf}\n" }
        if ($write) {
            $users{$fh}->{recv_buf} = '';
            $local{sender}->remove($fh);
        }
        else { warn "Error sending data to $users{$fh}->{nick}: $!\nData saved.\n" }
    }

    foreach my $fh (@{ $queues[0] }) {
        if ($fh != $local{listen}) {
            my $sent_buf;
            my $read = sysread($fh, $sent_buf, $local{read_size});
            if ($read) {
                my @bufs = split(/\n/, $sent_buf);
                foreach my $args (@bufs) {
                    process_command($fh, $args);
                    if ($users{$fh}->{nick} && $debug) { print "Received from $users{$fh}->{hostname} ($users{$fh}->{nick}): $args\n" }
                    elsif ($debug) { print "Received from $users{$fh}->{hostname}: $args\n" }
                }
            }
            else { push @clients_to_disconnect, $fh }
            # If data can't be read, the client either disconnected or there was an error. Either way, get rid of their data.
        }
        else {
            my $fh = $local{listen}->accept;
            $users{$fh} = {};
            $local{reader}->add($fh);
            send_user_msg_serv($fh, 'NOTICE AUTH :*** Looking up your hostname...');
            if (look_up_host($fh)) { send_user_msg_serv($fh, "NOTICE AUTH :*** Hostname found: $users{$fh}->{hostname}") }
            else { send_user_msg_serv($fh, "NOTICE AUTH :*** Hostname not resolved. Using IP instead: ($users{$fh}->{hostname})") }
            $users{$fh}->{connected} = 0;
        }
    }

    connect_new_clients()                            if $clients_to_connect[0];    # Don't call if there's nothing there.
    disconnect_dead_clients(\@clients_to_disconnect) if $clients_to_disconnect[0]; # Ditto.
}

###########################################################################
# Subroutines to handle logging on and logging off:
###########################################################################

# Does DNS and reverse DNS to find socket's full and real host.
sub look_up_host {
    my ($fh) = @_;
    my $other_end = getpeername($fh);
    my $iaddr = (unpack_sockaddr_in($other_end))[1];
    my $actual_ip = inet_ntoa($iaddr);
    my $claimed_hostname = gethostbyaddr($iaddr, AF_INET);
    my $name_lookup = (gethostbyname($claimed_hostname))[0];

    if ($name_lookup) {
        $users{$fh}->{hostname} = $name_lookup;
        1;
    }
    else {
        $users{$fh}->{hostname} = $actual_ip;
        return;
    }
}

# Occurs after NICK and USER are received and user is registered. This would use a variable created in the
# while loop like @clients_to_disconnect, but it's used by serv_nick() and serv_user(), so no go until
# a workaround is thought up.
sub connect_new_clients {
    # Increase user count based on the number of waiting clients.
    $local{users}               += @clients_to_connect;
    $local{non_invisible_users} += @clients_to_connect;
    $local{record_users}         = $local{users} > $local{record_users} ? $local{users} : $local{record_users};

    foreach my $fh (@clients_to_connect) {
        print "Client connected: $users{$fh}->{hostname} ($users{$fh}->{nick})\n";
        $users{$fh}->{connected} = 1;
        send_user_msg_num($fh, $RPL_WELCOME, $local{network}, $users{$fh}->{nick}, $users{$fh}->{username}, $users{$fh}->{hostname});
        send_user_msg_num($fh, $RPL_YOURHOST, $local{server}, $local{version});
        send_user_msg_num($fh, $RPL_CREATED, $local{start_date});
        serv_lusers($fh);
        serv_motd($fh);
    }

    undef @clients_to_connect;
}

# Used to disconnect and clear the data of any clients that have disconnected.
sub disconnect_dead_clients {
    my ($clients_to_disconnect) = @_;
    # Decrease the user counts based on the number of disconnected clients here.
    $local{users}               -= @$clients_to_disconnect;
    $local{non_invisible_users} -= @$clients_to_disconnect;

    foreach my $fh (@$clients_to_disconnect) {
        print "Client disconnected: $users{$fh}->{hostname} ($users{$fh}->{nick})\n";
        my $write = syswrite($fh, $users{$fh}->{recv_buf});
        if ($users{$fh}->{nick} && $debug) { print "Sending to $users{$fh}->{hostname} ($users{$fh}->{nick}): $users{$fh}->{recv_buf}\n" }
        elsif ($debug) { print "Sending to $users{$fh}->{hostname}: $users{$fh}->{recv_buf}\n" }
        if (!$write) { warn "Could not flush $users{$fh}->{nick}'s data.\n" }
        $local{reader}->remove($fh);
        $local{sender}->remove($fh);
        my $nick = $users{$fh}->{nick};
        if ($nick) { delete $users{lc $nick} }
        delete $users{$fh};
        $fh->close; # Oddly enough, if I do this any sooner, it screws up.
    }
}

###########################################################################
# To prevent confusion on the subroutines that accept multi-word arguments:
# my ($fh, $output) = @_ works because even though the output may be
# multiple words, it is passed as one argument in a double-quoted string.
#
# Subroutines to send data:
###########################################################################


# Sends data prefixed with the user's full address. Used for messages.
sub send_user_msg_addr {
    my ($fh, $output) = @_;
    my $message = ":$users{$fh}->{nick}!$users{$fh}->{username}\@$users{$fh}->{hostname} ";
    $message .= "$output\n";
    $users{$fh}->{recv_buf} .= $message;
    $local{sender}->add($fh);
}

# Sends data prefixed with the server name. Used for data that doesn't have a numeric, like server notices.
sub send_user_msg_serv {
    my ($fh, $output) = @_;
    my $message = ":$local{server} ";
    $message .= "$output\n";
    $users{$fh}->{recv_buf} .= $message;
    $local{sender}->add($fh);
}

# Send exactly what we're given. Used for all other messages.
sub send_user_msg_raw {
    my ($fh, $output) = @_;
    my $message .= "$output\n";
    $users{$fh}->{recv_buf} .= $message;
    $local{sender}->add($fh);
}

# Sends data prefixed with the server name and the supplied numeric. Used for server numerics.
sub send_user_msg_num {
    my ($fh, $numeric, @args) = @_;
    my $message;
    if ($users{$fh}->{connected}) { $message = ":$local{server} $numeric $users{$fh}->{nick} " }
    else { $message = ":$local{server} $numeric * " }

    $message .= sprintf "$numstr{$numeric}", @args;

    $message .= "\n";
    $users{$fh}->{recv_buf} .= $message;
    $local{sender}->add($fh);
}

###########################################################################
# Subroutines to handle incoming commands:
###########################################################################

# Used to get a command and redirect it to the proper subroutine to handle the command.
# Also returns an error for unknown commands.

sub process_command {
    my ($fh, $args) = @_;
    my $command = (split / /, $args)[0];
    $command = lc $command;

    # That's to catch anyone trying to send any other commands when they're not registered.
    if (!$users{$fh}->{connected} && ($command ne 'nick' && $command ne 'user')) { send_user_msg_num($fh, $ERR_NOTREGISTERED, $command); return; }

    if (exists $commhash{$command}) { $commhash{$command}->($fh, $args) }
    else { send_user_msg_num($fh, $ERR_UNKNOWNCOMMAND, $command) }
}

# Handles the user command. If NICK has already been issued, logs on.
sub serv_user {
    my ($fh, $args) = @_;
    my @user_info = split / /, $args;

    if (!$users{$fh}->{connected}) {
        if (@user_info < 5) { send_user_msg_num($fh, $ERR_NEEDMOREPARAMS, 'USER'); return; }
        $users{$fh}->{username} = "~$user_info[1]";
        for (4..$#user_info) {
            if ($_ ne $#user_info) { $users{$fh}->{realname} .= "$user_info[$_] " }
            else { $users{$fh}->{realname} .= $user_info[$_] }
        }
        if ($users{$fh}->{nick_done}) {
            delete $users{$fh}->{nick_done};
            push @clients_to_connect, $fh;
        }
        else { $users{$fh}->{user_done} = 1 }
    }
    else { send_user_msg_num($fh, $ERR_ALREADYREGISTERED) }
}

# Handles the nick command. If NICK has already been issued, logs on.
# Also handles nick changes.
sub serv_nick {
    my ($fh, $args) = @_;
    my $nick = (split / /, $args)[1];
    if (!$nick) { send_user_msg_num($fh, $ERR_NONICKNAMEGIVEN); return; }

    $nick =~ s/^\://;
    $nick = substr($nick, 0, 30);

    if ($users{$fh}->{connected}) {
        if ($nick eq $users{$fh}->{nick}) { return }
     
        # a-z A-Z 0-9 ^ _ - ` \ [ ] { } | are the valid characters. Nick can't start with a digit or a -.
        elsif (($nick =~ /^[0-9]/) || ($nick =~ /[^a-zA-Z0-9\^_\-\`\\\[\]\{\}\|]/) || ($nick =~ /^\-/)) {
            send_user_msg_num($fh, $ERR_ERRONEUSNICKNAME, $nick, 'Illegal characters');
        }
        elsif ($nick =~ /^NickServ$/i) {
            send_user_msg_num($fh, $ERR_ERRONEUSNICKNAME, 'NickServ', 'No password stealing. Thanks.');
        }
        elsif ($users{lc $nick}) {
            my $nick_in_use = $users{lc $nick};
            send_user_msg_num($fh, $ERR_NICKNAMEINUSE, $users{$nick_in_use}->{nick});
        }
        else {
            # We have to send_user_msg_addr first so that the nick message comes out with the proper address:
            send_user_msg_addr($fh, "NICK :$nick");
            my $old_nick = $users{$fh}->{nick};
            delete $users{lc $old_nick};
            $users{lc $nick} = $fh;
            $users{$fh}->{nick} = $nick;
        }

    }
    else {
        if (($nick =~ /^[0-9]/) || ($nick =~ /[^a-zA-Z0-9\^_\-\`\\\[\]\{\}\|]/) || ($nick =~ /^\-/)) {
            send_user_msg_num($fh, $ERR_ERRONEUSNICKNAME, $nick, 'Illegal characters');
        }
        elsif ($nick =~ /^NickServ$/i) {
            send_user_msg_num($fh, $ERR_ERRONEUSNICKNAME, 'NickServ', 'No password stealing. Thanks.');
        }
        elsif ($users{lc $nick}) {
            my $nick_in_use = $users{lc $nick};
            send_user_msg_num($fh, $ERR_NICKNAMEINUSE, $users{$nick_in_use}->{nick});
        }
        else {
            $users{$fh}->{nick} = $nick;
            $users{lc $nick} = $fh;
            if ($users{$fh}->{user_done}) {
                delete $users{$fh}->{user_done};
                push @clients_to_connect, $fh;
            }
            else { $users{$fh}->{nick_done} = 1 }
        }

    }
}

# Sends off NOTICEs and PRIVMSGs.
sub serv_privmsg {
    my ($fh, $args) = @_;
    my ($nick, $message_text) = (split / /, $args)[1, 2];
    if (!$message_text) { send_user_msg_num($fh, $ERR_NOTEXTTOSEND); return; }

    if ($users{lc $nick}) {
        my $receiving_fh = $users{lc $nick};
        my $message = ":$users{$fh}->{nick}!$users{$fh}->{username}\@$users{$fh}->{hostname} $args";
        send_user_msg_raw($receiving_fh, $message);
    }
    else { send_user_msg_num($fh, $ERR_NOSUCHNICK, $nick) }
}

# Returns whois data about a nick.
sub serv_whois {
    my ($fh, $args) = @_;
    my $nick = (split / /, $args)[1];
    if (!$nick) { send_user_msg_num($fh, $ERR_NONICKNAMEGIVEN); return; }

    if ($users{lc $nick}) {
        my $fh_of_whoised_nick = $users{lc $nick};
        send_user_msg_num($fh, $RPL_WHOISUSER, $users{$fh_of_whoised_nick}->{nick}, $users{$fh_of_whoised_nick}->{username}, $users{$fh_of_whoised_nick}->{hostname}, $users{$fh_of_whoised_nick}->{realname});
        send_user_msg_num($fh, $RPL_WHOISSERVER, $users{$fh_of_whoised_nick}->{nick}, $local{server}, $local{server_desc});
        send_user_msg_num($fh, $RPL_ENDOFWHOIS, $users{$fh_of_whoised_nick}->{nick});
    }
    else {
        send_user_msg_num($fh, $ERR_NOSUCHNICK, $nick);
        send_user_msg_num($fh, $RPL_ENDOFWHOIS, $nick);
    }
}

# Returns server connection data.
sub serv_lusers {
    my ($fh) = @_;
    send_user_msg_num($fh, $RPL_LUSERCLIENT, $local{non_invisible_users}, $local{invisible_users}, $local{servers});
    send_user_msg_num($fh, $RPL_LUSEROP, $local{operators});
    send_user_msg_num($fh, $RPL_LUSERUNKNOWN);
    send_user_msg_num($fh, $RPL_LUSERCHANNELS, $local{channels});
    send_user_msg_num($fh, $RPL_LUSERME, $local{users}, $local{servers});
    send_user_msg_num($fh, $RPL_LOCALUSERS, $local{users}, $local{record_users});
    send_user_msg_num($fh, $RPL_GLOBALUSERS, $local{users}, $local{record_users});
}

# Returns the message of the day.

sub serv_motd {
    my ($fh) = @_;
    if (open MOTD, $local{motd_file}) {
        send_user_msg_num($fh, $RPL_MOTDSTART, $local{server});
        while (<MOTD>) { send_user_msg_num($fh, $RPL_MOTD, $_) }
        close MOTD;
        send_user_msg_num($fh, $RPL_ENDOFMOTD);
    }
    else {
        send_user_msg_num($fh, $ERR_NOMOTD);
        warn "MOTD could not be opened: $!\n";
    }
}

sub serv_online {
    # %fhs is gone. How's this work now?
    my ($fh) = @_;
    #send_user_msg_serv($fh, "NOTICE :Current online nicks ($local{users} total): ");
    #foreach my $fhs (values %fhs) { send_user_msg_serv($fh, "NOTICE :$users{$fhs}->{nick}") }
    send_user_msg_serv($fh, "NOTICE :Broken, fix later.");
}

###########################################################################
# Other subroutines:
###########################################################################

# Supply a date to show when the server was started.
sub get_date {
    my @args = split / /, localtime $^T;
    "@args[0, 1, 2, 4] at $args[3] CST";
}