#!/usr/bin/perl -w
#
# medusa.pl, a partyline system
# version 2.0.1 by Pegasus Epsilon <pegasus@pimpninjas.org>
#
# (C) 2014, All Rights Reserved
#
# NOTICE: This is not free software. Modification is not permitted.
# NOTICE: This is not free software. Distribution is not permitted.
# NOTICE: This is not free software. For author's use only.
use strict;
use POSIX;
use Socket;
use Fcntl;
sub fail { print @_; exit; }
sub lookup { local ($_, %_) = reverse @_; $_{$_} }
my $port = shift || 40000;
fail("Usage: $0 port\n") unless $port;
$0 = join " ", "medusa (console)";
my $banner = "Medusa (Jellyfish server) 2.0.1 by Pegasus Epsilon <pegasus\@pimpninjas.org>";
print "$banner\n";
my (%pid2pipe, %pid2nick);
$pid2pipe{$$} = \*STDOUT;
$pid2nick{$$} = "CONSOLE";
pipe QUEUE_OUT, QUEUE_IN;
$SIG{PIPE} = sub { print "[$$:STDOUT] SIGPIPE?!\n"; };
$SIG{CHLD} = sub {
if (0 < (my $pid = waitpid(-1, WNOHANG))) {
delete $pid2nick{$pid} if exists $pid2nick{$pid};
delete $pid2pipe{$pid} if exists $pid2pipe{$pid};
print "[$$:STDOUT] Reaped $pid\n";
}
};
$SIG{INT} = sub { print "\r[$$:STDOUT] Try /jf die to kill me.\n"; };
socket LISTEN, PF_INET, SOCK_STREAM, (getprotobyname 'tcp')[2];
setsockopt LISTEN, SOL_SOCKET, SO_REUSEADDR, pack("l", 1);
bind LISTEN, sockaddr_in($port, INADDR_ANY)
or fail("[$$:STDOUT] Can't bind socket: $!\n");
listen(LISTEN, 10);
print "Medusa listening on $port...\n";
# set all outputs hot
select(((select $_), $| = 1)[0]) for (\*STDOUT, \*QUEUE_IN);
# set everything nonblocking and prepare inputs for select loop
my $inputs = ''; my ($fd_stdin, $fd_listen, $fd_queue_out) = map {
fcntl $_, F_SETFL, O_NONBLOCK;
vec($inputs, $_ = fileno $_, 1) = 1;
$_
} (\*STDIN, \*LISTEN, \*QUEUE_OUT);
# server event loop
while (my $n = select(my $readable = $inputs, undef, my $exception = $inputs, undef)) {
# ignore interrupted system calls
if (-1 == $n && $!{EINTR}) { undef $!; next }
# complain about other exceptions
if ($exception =~ /[^\0]/) {
print "[$$:STDOUT] [DEBUG] Exceptions: ", unpack('b*', $exception), ", $!, \$n: $n\n";
undef $!; next
}
# accept incoming connections
if (vec($readable, $fd_listen, 1) && (my ($pid, $nick, $pipe) = new_client())) {
$pid2pipe{$pid} = $pipe; $pid2nick{$pid} = $nick; next
}
# handle console input
if (vec($readable, $fd_stdin, 1)) {
defined(local $_ = <STDIN>) or do {
print "[$$:STDOUT] EOF stdin, ignoring...\n";
next
};
while () {
s/[\r\n]+//g;
next unless (length);
# local console commands go here
if (s!^/me !!) { enqueue("[$$:*] * CONSOLE $_"); }
# enabling /nick for console is easy enough, but should it be enabled?
elsif (s!^/nick !!) { print "[$$:STDOUT] CONSOLE may not change nick.\n"; }
elsif (s!^/(shutdown|exit|quit|stop|die)\b!!) {
print "[$$:STDOUT] Use /jf $1 to stop medusa.\n";
}
elsif (m!^/list!) { enqueue("[$$:JF] list"); }
elsif (s!^/([^ ]+) !!) { enqueue("[$$:$1] $_"); }
else { enqueue("[$$:*] <CONSOLE> $_"); }
} continue { defined($_ = <STDIN>) or last };
}
# handle message queue
if (vec($readable, $fd_queue_out, 1)) {
local $_ = <QUEUE_OUT> || do {
print "[$$:STDOUT] EOF broadcast queue, ignoring...";
next;
};
while () {
s/[\r\n]+//g;
next unless (length);
# JF target
if (s!^\[([^]:]+):JF\] !!i) {
my $pipe = $pid2pipe{my $pid = $1};
# more jellyfish commands here
if (m!^list!) {
print $pipe "[JF:$pid] [JF] ", join(', ', values %pid2nick), "\r\n";
next;
}
if (m!^(shutdown|exit|quit|stop|die)!) {
announce("[JF:*] Medusa is shutting down...");
exit;
}
if (s!^nick !!) { $pid2nick{$pid} = uc $_; next }
print $pipe "[JF:$pid] Invalid command.\r\n";
next;
}
# other targets
if (s!^\[([^]:]+):([^]:]+)\] !!) {
my ($src, $tgt) = ($1, lookup(%pid2nick, uc $2) || $2);
# this allows authenticated users to impersonate. disable?
if ($tgt eq "*") { announce("[$src:*] $_"); next }
if (defined(my $pipe = $pid2pipe{$tgt})) {
print $pipe "[$src:$tgt] $_\r\n";
} else {
my $pipe = $pid2pipe{$src};
print $pipe "[JF:$src] Client $tgt is not connected.\r\n";
}
next;
}
print "Unknown message in queue: >>$_<<\n";
} continue { defined($_ = <QUEUE_OUT>) or last };
}
}
sub ban { return; } # FIXME
sub announce { print $_ "$_[0]\r\n" for (values %pid2pipe); }
sub enqueue {
local $_ = shift;
s/[\r\n]+//g;
print QUEUE_IN "$_\n";
}
sub authenticate {
my ($client_id, $user, $pass, $db) = @_;
open(*DB, '<', $db) or return;
for (<DB>) {
s!^$user:!! || next;
s/[\r\n]+//g;
if ($_ eq $pass) {
enqueue("[$$:JF] nick $user");
enqueue("[$$:*] [JF] $client_id is now known as $user");
$0 = "[medusa] $user (logged in)";
close DB;
return $user;
}
}
close DB;
return;
}
sub new_client {
my $paddr = accept CLIENT, LISTEN;
# abort if accept failed
return if $!{EINTR} | $!{EWOULDBLOCK};
pipe SERVER, my $pipe;
select(((select $_), $| = 1)[0]) for (\*CLIENT, $pipe);
fcntl $_, F_SETFL, O_NONBLOCK for (\*CLIENT, \*SERVER);
my $client_id = do {
use Digest::CRC 'crc32_hex';
my ($rport, $raddr) = sockaddr_in($paddr);
my $remote = inet_ntoa($raddr).":$rport";
local $_ = uc crc32_hex $remote;
enqueue("[$$:*] [JF] $_ connected");
print "[$$:STDOUT] $remote connected as $_\n";
$_;
};
if (my $pid = fork) {
close CLIENT; close SERVER;
return $pid, $client_id, $pipe;
}
close $pipe;
close LISTEN;
$0 = "[medusa] $client_id";
my ($brutecounter, $relay, $admin) = 5;
my ($lastline, $floodcount, $autoban) = ('', 0, 0);
my $inputs = ''; vec($inputs, $_, 1) = 1
for (my ($fd_client, $fd_server) = (fileno CLIENT, fileno SERVER));
# client event loop
print CLIENT "$banner\r\n";
while (my $n = select(my $readable = $inputs, undef, my $exception = $inputs, undef)) {
# ignore interrupted system calls
if (-1 == $n && $!{EINTR}) { undef $!; next; }
# complain about other exceptions
if (vec($exception, $fd_client, 1)) {
print "[$$:STDOUT] [DEBUG] Exceptions: ", unpack("b*", $exception), ", $!, \$n: $n\n";
exit;
}
if (vec($exception, $fd_server, 1)) {
print CLIENT "[JF] Server closed.\r\n";
exit;
}
# read client input
if (vec($readable, $fd_client, 1)) {
local $_ = <CLIENT> || do {
enqueue("[$$:*] [JF] $client_id disconnected.");
exit;
};
while () {
s/[\r\n]+//g;
next unless length;
# relays go straight through, no checks needed,
# private messages/commands allowed, but no JF commands.
if ($relay) {
if (m!^/jf\b!) { print CLIENT "[JF] Stop that.\r\n"; next }
if (m!^/list$!) { enqueue("[$$:JF] list"); next }
if (s!^/([^ ]+) !!) { enqueue("[$$:$1] $_"); next }
enqueue("[$$:*] $_"); next
}
# anonymous clients get flood controlled, message tagged,
# and a few commands
if (!$admin && $lastline eq $_ && $floodcount++ >= 5) {
print CLIENT "[JF] Flooding is not allowed.\r\n";
if (1 == $floodcount && $autoban++ >= 5) { ban(); } # FIXME
next;
}
$floodcount = 0; # FIXME?
$lastline = $_;
if (s!^/me !!) { enqueue("[$$:*] * $client_id $_"); next }
if (m!^/quit\b!) {
print CLIENT "Goodbye.\r\n";
enqueue("[$$:*] [JF] $client_id quit.");
exit;
}
if (s!^/(JF )?login !!i) {
local @_ = split / /, $_;
print "[$$:STDOUT] $client_id is trying to log in as $_[0]\n";
$admin = authenticate($client_id, @_, 'admins.auth');
$relay = authenticate($client_id, @_, 'relays.auth');
$client_id = $admin || $relay || $client_id;
next;
}
# admins get no flood control, and command rights
if ($admin) {
if (s!^/nick !!) {
enqueue("[$$:JF] nick $_");
enqueue("[$$:*] $client_id is now known as $_");
$client_id = $_; next
}
# server commands = /servername whatever
if (s!^/([^ ]+) !!) {
enqueue("[$$:$1] $_");
next
}
}
enqueue("[$$:*] <$client_id> $_");
} continue { defined($_ = <CLIENT>) or last };
}
# read server input
if (vec($readable, $fd_server, 1)) {
local $_ = <SERVER> || do {
print CLIENT "[JF] Server closed\r\n";
exit;
};
# relays ignore echo
next if $relay && /^\[$$:[^]]+\]/;
while () {
s/[\r\n]+//g;
next unless length;
print CLIENT "$_\r\n";
} continue { defined($_ = <SERVER>) or last };
}
}
close CLIENT;
exit;
}