Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
652 lines (504 sloc) 16 KB
#!/usr/bin/perl -w
# Copyright (c) 2011, Mitchell Cooper
package user;
use warnings;
use strict;
use feature qw/say switch/;
use utils qw/col conf oper hostmatch snotice validnick validcloak/;
use userhandlers;
$utils::GV{'cid'} = $utils::GV{'max'} = 0;
our (%connection, %commands);
# register the command handlers in userhandlers.pm
&userhandlers::get;
# main command handler
sub handle {
my ($user, $rcommand, $data) = @_;
my $command = uc $rcommand;
if (exists $commands{$command}) {
# check for the required number of parameters
my @params = split /\s+/, $data;
if ($commands{$command}{params} &&
$commands{$command}{params} > $#params) {
$user->numeric(461, $rcommand);
return
}
# check for required flag
if ($commands{$command}{flag} && !$user->can($commands{$command}{flag})) {
$user->numeric(481);
return
}
return $commands{$command}{'code'}($user, $data)
}
# unknown command
else {
$user->numeric(421, $rcommand)
}
return
}
# create a new user
sub new {
my ($this, $ssl, $peer) = @_;
return unless $peer;
# the server is not accepting connections
if (!&acceptcheck) {
$peer->close;
return
}
# check and make sure the IP is not D-Lined, blacklisted, or if it has reached its max-per-IP limit
my @ip_accept = ip_accept($peer->peerhost);
if (!$ip_accept[0]) {
# we can't use main::sendpeer here because the outbuffer will be cleared before the main loop gets a chance to send the data
$peer->syswrite('ERROR :Closing Link: (*@'.$peer->peerhost.') ['.$ip_accept[1].']'."\r\n", POSIX::BUFSIZ);
$peer->close;
return
}
# add the user to the IO::Select object
$::select->add($peer);
::sendpeer($peer, ':'.(conf qw/server name/).' NOTICE * :*** Looking up your hostname...');
my $ip = $peer->peerhost;
my $ipv = ($ip =~ m/:/ ? 6 : 4);
# create the user
bless my $user = {
ssl => $ssl,
server => $::id,
id => $::id.&newid,
obj => $peer,
ip => $ip,
ipv => $ipv,
host => $ip,
cloak => $ip,
time => time,
privs => []
}, $this;
# set PING rate, idle time, and other timers
handle::user_reset_timer($user, 0);
$user->servernotice('*** Could not resolve hostname; using IP address instead');
$connection{$peer} = $user;
return $user
}
# this is where the actual mode setting is done; mode handling is done in hmodes()
sub setmode {
my ($user, $modes, $silent) = @_;
$user->send(':'.$user->nick.' MODE '.$user->nick.' :+'.$modes) unless $silent;
foreach (split //, $modes) {
$user->{'mode'}->{$_} = time;
# don't do anything for these modes
next if $_ =~ m/i/;
if ($_ eq 'x' && conf qw/enabled cloaking/) {
# use . for IPv4 and : for IPv6
my $sep = ($user->{'ipv'} == 6 ? ':' : '\.');
# set the hidden host
$user->setcloak(host2cloak($sep, $user->{'host'}))
}
}
}
sub ismode {
my ($user, $mode) = @_;
return $user->{'mode'}->{$mode} if exists $user->{'mode'}->{$mode};
return
}
# this is where the actual mode unsetting is done; mode handling is done in hmodes()
sub unsetmode {
my ($user, $modes, $silent) = @_;
$user->send(':'.$user->nick.' MODE '.$user->nick.' :-'.$modes) unless $silent;
foreach (split //, $modes) {
delete $user->{'mode'}->{$_};
next if $_ =~ m/(i|S)/;
if ($_ eq 'x' && conf qw/enabled cloaking/) {
# restore the original cloak
$user->unsetcloak;
}
elsif ($_ eq 'o') {
# remove all privs
$user->{privs} = [];
# unset server notices if set
$user->unsetmode('S') if $user->ismode('S');
}
}
}
sub hmodes {
my ($user, $modes) = @_;
return unless $modes;
# modes that always exist, whether or not a feature is enabled or disabled
my @enabled_modes = 'i';
push @enabled_modes, 'x' if conf qw/enabled cloaking/;
my $state = 1;
foreach my $piece (split //, $modes) {
given ($piece) {
when ('+') {
$state = 1
}
when ('-') {
$state = 0
}
# modes that cannot be set or unset
when ('Z') {
next
}
# oper-only modes
when (/(o|S)/) {
if ($user->ismode('o')) {
if ($state) {
$user->setmode($piece)
}
else {
$user->unsetmode($piece)
}
}
# otherwise just ignore it
}
# normal modes
when ($_ ~~ @enabled_modes) {
if ($state) {
$user->setmode($piece)
}
else {
$user->unsetmode($piece)
}
}
# unknown mode
default {
$user->numeric(501, $piece)
}
}
}
}
# set the displayed host of a user
sub setcloak {
my ($user, $cloak) = @_;
$user->numeric(396, $cloak);
$user->{'cloak'} = $cloak;
return $cloak
}
# create an SHA cloak of a host
sub host2cloak {
my @pieces = ();
my $sep = shift;
foreach (split $sep, shift) {
my $part = sha1_hex($_, (conf qw/cloak salt/), $#pieces);
# create six-character section
$part = ($part =~ m/....../g)[0];
push @pieces, $part;
}
# since split requires . to be escaped
$sep = q(.) if $sep eq '\.';
return (join $sep, @pieces)
}
# restore original host
sub unsetcloak {
my $user = shift;
$user->numeric(396, $user->host);
$user->{'cloak'} = $user->host;
return $user->host
}
# find a user by their socket object
sub lookup {
my $peer = shift;
return $connection{$peer} if exists $connection{$peer};
# no such user
return
}
# send data
sub send {
return ::sendpeer(shift->obj, @_)
}
# check for an oper flag
sub can {
my ($user, $priv) = @_;
return 1 if $priv ~~ @{$user->{privs}};
# they don't have that priv
return
}
# user quit
sub quit {
my ($user, $reason, $silent, $display, $no_notice) = @_;
# relay the quit to all users in a common channel, but only once.
my %sent;
foreach my $channel (values %channel::channels) {
if ($user->ison($channel)) {
foreach (keys %{$channel->{'users'}}) {
lookupbyid($_)->send(':'.$user->fullcloak.' QUIT :'.($display ? $display : $reason)) unless $sent{$_};
$sent{$_} = 1
}
}
# remove the user from the channel
# this has to be outside of the ison() because some data (such as invites) do not require that the user is in the channel
$channel->remove($user)
}
snotice('client exiting: '.$user->fullhost.' ['.$user->{'ip'}.'] ('.$reason.')') if $user->{'ready'} && !$no_notice;
# we can't use main::sendpeer here because the outbuffer will be cleared before the main loop gets a chance to send the data
$user->obj->syswrite('ERROR :Closing Link: ('.(defined $user->{'ident'} ? $user->{'ident'} : q(*)).'@'.$user->host.') ['.$reason.']'."\r\n", POSIX::BUFSIZ) unless $silent;
# delete their data
delete $connection{$user->obj};
delete $::outbuffer{$user->obj};
delete $::timer{$user->obj};
# remove the user from the IO::Select object and close the socket
$::select->remove($user->obj);
$user->obj->close;
undef $user;
# double-check if the server is ready to accept new connections
&acceptcheck;
return 1
}
# send a NOTICE from the server
# :server NOTICE nick :message
sub servernotice {
my $user = shift;
return $user->send(':'.(conf qw/server name/).' NOTICE '.$user->nick." :@_")
}
# server notice for a command such as CHGHOST
sub snt {
return shift->servernotice(sprintf '*** %s: %s', shift, shift)
}
# send a numeric
# deprecated; use numeric() instead.
# (this is still used in the start() function as those numerics are only used once,
# or at least until the VERSION command is complete.)
sub sendnum {
my $user = shift;
return $user->send(':'.(conf qw/server name/).q( ).shift().q( ).$user->nick." @_")
}
# new way to send a numeric
# numerics are defined in the %utils::numerics hash
# a single numeric can have multiple strings since int() is used.
sub numeric {
my ($user, $num) = (shift, shift);
return $user->send(join q. ., ':'.(conf qw/server name/), (int $num), $user->nick, (sprintf $utils::numerics{$num}, @_))
}
# send data from the server
sub sendserv {
return shift->send(':'.(conf qw/server name/).q( ).(sprintf shift, @_))
}
# send from the server, join()ing the arguments by a space
sub sendservj {
return shift->send(':'.(conf qw/server name/).q( ).(join q. ., @_))
}
# send data from a server or user
sub sendfrom {
return shift->send(':'.shift().q( ).(sprintf shift, @_))
}
# send from a server or user, using join(q( )) for each argument
sub sendfromj {
return shift->send(':'.shift().q( ).(join q. ., @_))
}
# the entire mask, using the displayed host
sub fullcloak {
my $user = shift;
return $user->{'nick'}.'!'.$user->{'ident'}.'@'.$user->{'cloak'} if $user->{'ready'};
return '*'
}
# sends a privmsg to a user
# who knows why this has its own function? it's only used once...
sub recvprivmsg {
my ($user, $from, $target, $msg, $cmd) = @_;
return $user->send(':'.(join q. ., $from, $cmd, $target).' :'.$msg)
}
# look for a usermode set on the user
sub mode {
my ($user, $mode) = @_;
# found it
return $user->{'mode'}->{$mode} if exists $user->{'mode'}->{$mode};
# doesn't have mode set
return
}
# the entire mask, using the actual host
sub fullhost {
my $user = shift;
return $user->{'nick'}.'!'.$user->{'ident'}.'@'.$user->{'host'} if defined $user->{'ready'};
return '*'
}
# user's nick
sub nick {
my $user = shift;
return $user->{'nick'} if $user->{'nick'};
return '*'
}
# called by handle.pm after the user registers
sub start {
my $user = shift;
return if $user->checkkline(1);
snotice('client connecting: '.$user->fullhost.' ['.$user->{'ip'}.']');
$user->sendnum('001', ':Welcome to the '.(conf qw/server network/).' Internet Relay Chat Network '.$user->nick);
$user->sendnum('002', ':Your host is '.(conf qw/server name/).', running version juno-'.$::VERSION);
$user->sendnum('003', ':This server was created '.POSIX::strftime('%a %b %d %Y at %H:%M:%S %Z',localtime $::TIME));
$user->sendnum('004', (conf qw/server name/).' juno-'.$::VERSION.' SZiox AIZbelimntz');
$user->sendnum('005', 'CHANTYPES=# EXCEPTS INVEX CHANMODES=AeIbZ,k,l,imntz PREFIX=(qaohv)~&@%+ NETWORK='.(conf qw/server network/).' MODES='.(conf qw/limit chanmodes/).' NICKLEN='.(conf qw/limit nick/).' TOPICLEN='.(conf qw/limit topic/).' :are supported by this server');
# make the server think the user sent these commands
userhandlers::handle_lusers($user);
userhandlers::handle_motd($user);
# set automatic modes as defined in the configuration
$user->setmode((conf qw/user automodes/).($user->{'ssl'} ? 'Z' : q..));
return 1
}
# a new user ID (ID, not UID)
sub newid {
$utils::GV{'cid'}++;
return $utils::GV{'cid'}-1
}
# the user's UID
sub id {
return shift->{'id'}
}
# the user's IO::Socket object
sub obj {
return shift->{'obj'}
}
# the ID of the server the user is on
sub server {
return shift->{'server'}
}
# user's acutal host
sub host {
return shift->{'host'}
}
# check if a nickname exists and return that user's object if it does
sub nickexists {
my $nick = shift;
foreach (values %connection) {
# found a match
return $_ if lc $_->{'nick'} eq lc $nick
}
# no such nick
return
}
# find a user by their UID
sub lookupbyid {
my $id = shift;
foreach (values %connection) {
# found a match
return $_ if $_->{'id'} == $id
}
# no such UID
return
}
# check if a user has correct oper credentials
# TODO: add support for SHA encryption.
sub canoper {
my ($user, $oper, $password) = @_;
return unless exists $::oper{$oper};
# check if the password is correct
if (oper($oper, 'password') eq crypt($password, oper($oper, 'salt'))) {
# check if the mask is correct
return $oper if hostmatch($user->fullhost, (split / /, oper($oper, 'host')))
}
# invalid credentials
return
}
# check if a user is on a channel (by objects, not names)
sub ison {
my ($user, $channel) = @_;
return 1 if exists $channel->{'users'}->{$user->{'id'}};
return
}
# check if the user's mask matches a K-Line in the configuration
# if it does, force them to quit
sub checkkline {
my $user = shift;
my $silent = shift;
foreach (keys %::kline) {
if (hostmatch(lc "$$user{ident}\@$$user{host}", lc $_)) {
# found a match; forcing them to quit
$user->quit('K-Lined: '.$::kline{$_}{'reason'}, undef, 'K-Lined'.((conf qw/main showkline/) ? ': '.$::kline{$_}{'reason'}:''), $silent);
return 1
}
}
# they're free to go
return
}
# ensure that the server is accepting connections
sub acceptcheck {
my $i = scalar keys %connection;
# maximum client count reached
if ($i == conf qw/limit clients/) {
snotice('No new clients are being accepted. ('.$i.' users)') if $::ACCEPTING != 0;
$::ACCEPTING = 0;
return
}
# person(s) quit; accepting clients again
else {
snotice('Clients are now being accepted. ('.$i.' users)') if $::ACCEPTING != 1;
$::ACCEPTING = 1;
return 1
}
}
# make sure the max-per-ip limit has not been reached and that the IP is not dlined.
sub ip_accept {
my $ip = shift;
my $count = 0;
foreach (values %connection) {
$count++ if $_->{'ip'} eq $ip
}
# limit reached
return (undef, 'Too many connections from this host') if $count >= conf qw/limit perip/;
foreach (keys %::dline) {
# IP matches a D-Line in the configuration
return (undef, 'D-Lined: '.$::dline{$_}{'reason'}) if hostmatch($ip, $_)
}
# they're free to go
return 1
}
# import the selected encrypting
sub DigestImport {
say ' Importing SHA1 support to cloaking module';
Digest::SHA->import('sha1_hex')
}
# add a command handler
# do NOT call this from an API module.
# see API::Command to do that.
sub register_handler {
my ($handler, $code, $source, $desc, $params, $flag) = @_;
$handler = uc $handler;
if (exists $commands{$handler}) {
# command already exists
say 'register_handler failed; '.$handler.' already exists.';
return
}
# success
$commands{$handler} = {
code => $code,
desc => $desc,
source => $source,
params => $params,
flag => $flag
};
say $source.' registered handler '.$handler.': '.$desc;
return 1
}
# delete a command handler
sub delete_handler {
my $command = uc shift;
# if it exists, delete it
if (exists $commands{$command}) {
delete $commands{$command};
return 1
}
# it doesn't
say 'delete_handler failed; '.$command.' does not exist.';
return
}
# add oper privs
sub add_privs {
my $user = shift;
# set o if not opered
$user->setmode('o') unless scalar @{$user->{privs}};
foreach my $priv (@_) {
# already has it
next if $priv ~~ @{$user->{privs}};
# doesn't have it
push @{$user->{privs}}, $priv
}
return 1
}
sub del_privs {
my $user = shift;
my @finished;
foreach my $priv (@{$user->{privs}}) {
next if $priv ~~ @_;
push @finished, $priv
}
$user->{privs} = [@finished];
# check if they are still opered just in case
$user->unsetmode('o') unless scalar @{$user->{privs}};
return 1
}
1