#!/usr/bin/perl
# The Veachian Internet Relay Chat Daemon - Coded by Jahn Veach/Veachi
+an64 - 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 REGISTERE
+D).
# 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 hashe
+s as values. Hashes contain user info.
my %local; # Hash containing all local info for the server. Ex. $loca
+l{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 Per
+l 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}, un
+def, 0.1);
my @clients_to_disconnect; # Array containing a list of filehandle
+s 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}: $u
+sers{$fh}->{recv_buf}\n" }
if ($write) {
$users{$fh}->{recv_buf} = '';
$local{sender}->remove($fh);
}
else { warn "Error sending data to $users{$fh}->{nick}: $!\nDa
+ta 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 "Receiv
+ed 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 A
+UTH :*** 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_co
+nnect[0]; # Don't call if there's nothing there.
disconnect_dead_clients(\@clients_to_disconnect) if $clients_to_di
+sconnect[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{v
+ersion});
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 disco
+nnected.
sub disconnect_dead_clients {
my ($clients_to_disconnect) = @_;
# Decrease the user counts based on the number of disconnected cli
+ents 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{$f
+h}->{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}: $u
+sers{$fh}->{recv_buf}\n" }
if (!$write) { warn "Could not flush $users{$fh}->{nick}'s dat
+a.\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 argum
+ents:
# my ($fh, $output) = @_ works because even though the output may be
# multiple words, it is passed as one argument in a double-quoted stri
+ng.
#
# 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}\@$user
+s{$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. U
+sed for server numerics.
sub send_user_msg_num {
my ($fh, $numeric, @args) = @_;
my $message;
if ($users{$fh}->{connected}) { $message = ":$local{server} $numer
+ic $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 ha
+ndle 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 th
+ey're not registered.
if (!$users{$fh}->{connected} && ($command ne 'nick' && $command n
+e 'user')) { send_user_msg_num($fh, $ERR_NOTREGISTERED, $command); re
+turn; }
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_NEEDMOREPARA
+MS, '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. Ni
+ck 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, 'Ille
+gal 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 mes
+sage 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, 'Ille
+gal 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); r
+eturn; }
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_n
+ick}->{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_user
+s}, $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{reco
+rd_users});
send_user_msg_num($fh, $RPL_GLOBALUSERS, $local{users}, $local{rec
+ord_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{use
+rs} 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";
}
|