Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

The Veachian IRC Daemon

by Veachian64 (Scribe)
on Mar 29, 2002 at 23:07 UTC ( [id://155351]=sourcecode: print w/replies, xml ) Need Help??
Category: Networking Code
Author/Contact Info Jahn Veach (Veachian64), V64@V64.net
Description: This is an IRC daemon I wrote out of sheer boredom in Perl. It's in the public domain, so if anyone wants to see a simplified example of an IRC server or how a server written in Perl works and use it for whatever they want, here it is. This is the latest version of the code. An archive containing all the previous versions of the code is available as a zip or a tarball. Read the README in the archive for more info.

Updated: 12/23/2002
#!/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";
}
Replies are listed 'Best First'.
A reply falls below the community's threshold of quality. You may see it by logging in.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://155351]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others chilling in the Monastery: (3)
As of 2024-03-29 15:43 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found