Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

The Veachian IRC Daemon

by Veachian64 (Scribe)
on Mar 29, 2002 at 23:07 UTC ( #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";
}

Comment on The Veachian IRC Daemon
Download Code
•Re: The Veachian IRC Daemon
by merlyn (Sage) on Mar 30, 2002 at 00:18 UTC
    I downvoted this. What happens a year from now when your link is dead? Why even talk about something that might move around or completely disappear?

    {sigh}

    Although, if it had been a CPAN link, I'd have simply done nothing.

    -- Randal L. Schwartz, Perl hacker

      Of course, if I could go back and do it all over again, I would have generalized this code and made it into a CPAN module so that everyone could've used it. Fortunately, it looks like POE::Component::Server::IRC filled that void.

      Out of sheer stubbornness, I've continued to maintain the original hyperlinks over the years, and I just recently put up a somewhat abbreviated repository of the code at https://github.com/v64/vircd.

      Let bygones be bygones?

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (15)
As of 2014-07-24 20:51 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (167 votes), past polls