#!/usr/bin/perl
# proxytee.pl, proxy between a set of dancer servers, dumping the traffic
#  between them to stdout
# Based on example 17-6 (recipe 17.13) in the perl cookbook (bighorn sheep)
#
# This file is copyright (C) 2001 Andrew Suffield
#                                  <asuffield@users.sourceforge.net>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA

use warnings;
use strict;
use Carp;
use POSIX;
use IO::Socket;
use IO::Select;
use Tie::RefHash;

my $port = 6667;
my %servers = ();
my %skip = ();
# Command filter
# (These commands will never be displayed)
foreach my $command (qw/PING PONG SPINGTIME/)
  {
    $skip{uc $command} = 1;
  }

read_config();
my (%inbuffer, %outbuffer, %ready, %peer, %preconnect_buffer, %name) = ((), (), (), (), (), ());
my (%client_name, %last_wallops, %last_wallops_to) = ((), (), ());
tie %ready, 'Tie::RefHash';
tie %preconnect_buffer, 'Tie::RefHash';

my $listener = IO::Socket::INET->new(LocalPort => $port,
				     Listen => SOMAXCONN,
				     ReuseAddr => 1,
				     Type => SOCK_STREAM)
  or croak "Couldn't listen on $port: $@\n";
nonblock($listener);
my $select = IO::Select->new();
$select->add($listener);

# Main polling loop
while (1)
  {
    foreach my $client ($select->can_read(1))
      {
	if ($client == $listener)
	  {
	    # We've got a new incoming connection. Accept it.
	    my $new_client = $listener->accept();
	    # OK, did that succeed?
	    if (defined $new_client)
	      {
		$select->add($new_client);
		nonblock($client);
	      }
	  }
	else
	  {
	    # Normal connection, incoming data
	    my $data = '';
	    my $rv = $client->recv($data, POSIX::BUFSIZ, 0);

	    unless (defined $rv and length $data)
	      {
		# Either EOF or some network error, clean up
		close_socket($peer{$client}) if exists $peer{$client};
		close_socket($client);
		next;
	      }

	    $inbuffer{$client} .= $data;

	    # OK, do we have a complete line?
	    while ($inbuffer{$client} =~ s/(.*\n)//)
	      {
		# Queue 'em up
		push @{$ready{$client}}, $1;
	      }
	  }
      }

    # Parse the processing queues
    foreach my $client (keys %ready)
      {
	handle($client);
      }

    # And flush outgoing buffers
    foreach my $client ($select->can_write(1))
      {
	next unless exists $outbuffer{$client};

	my $rv = $client->send($outbuffer{$client}, 0);
	unless (defined $rv)
	  {
	    warn "select said I could write, but send failed\n";
	    next;
	  }

	if ($rv == length $outbuffer{$client} || $! == POSIX::EWOULDBLOCK)
	  {
	    # We wrote something. Remove it from the buffer
	    substr($outbuffer{$client}, 0, $rv) = '';
	    delete $outbuffer{$client} if 0 == length $outbuffer{$client};
	  }
	else
	  {
	    # Something failed during write. Kill the connection.
	    close_socket($peer{$client}) if exists $peer{$client};
	    close_socket($client);
	    next
	  }
      }
  }

# NOT REACHED
exit;

sub handle
  {
    my $client = shift;
    foreach my $request (@{$ready{$client}})
      {
	$request =~ s/\r?\n$//;
	my ($prefix, $command, @args) = parse($request);
	if (exists $peer{$client})
	  {
	    unless (exists $skip{$command} or ($command eq 'NOTICE' and not defined $prefix))
	      {
		my $sargs = '';
		$sargs = join ' ', (@args) if (scalar @args);

		if ($command eq "WALLOPS")
		  {
		    # Eliminate forwarded WALLOPS
		    if ($name{$client} eq $prefix)
		      {
			# Eliminate repeated WALLOPS
			unless (defined $last_wallops{$name{$client}}
				and $last_wallops{$name{$client}} eq $sargs
				and $last_wallops_to{$name{$client}} ne $name{$peer{$client}})
			  {
			    print "$name{$client} WALLOPS $sargs\n" if $name{$client} eq $prefix;
			    $last_wallops{$name{$client}} = $sargs;
			    $last_wallops_to{$name{$client}} = $name{$peer{$client}};
			  }
		      }
		  }
		else
		  {
		    my $output = "$name{$client} -> $name{$peer{$client}} ";
		    $output .= ":$prefix " if defined $prefix;
		    $output .= $command;
		    $output .= " " . $sargs if length $sargs;
		    print "$output\n";
		  }
	      }
	    $outbuffer{$peer{$client}} .= "$request\r\n";
	  }
	else
	  {
	    push @{$preconnect_buffer{$client}}, $request;
	    if ($command eq 'CHALL' and defined $args[1])
	      {
		my ($from, $to) = ($args[0], $args[1]);
		print "Server connected, claiming to be $from, asking for $to\n";
		my $target = $servers{$to} if exists $servers{$to}
		  or do
		    {
		      print "Don't have a server record for $to\n";
		      close_socket($client);
		      return;
		    };
		my $target_socket = IO::Socket::INET->new(PeerAddr => $target->{addr},
							  PeerPort => $target->{port})
		  or do
		    {
		      print "Couldn't connect to ".$target->{addr}.':'.$target->{port}.": $@\n";
		      close_socket($client);
		      return;
		    };
		nonblock($target_socket);
		print "Connected to ".$target->{addr}.':'.$target->{port}.", repeating buffer\n";

		$peer{$client} = $target_socket;
		$peer{$target_socket} = $client;
		$name{$client} = $from;
		$client_name{$from} = $client;
		$name{$target_socket} = $to;
		$client_name{$to} = $target_socket;
		$select->add($target_socket);

		foreach my $line (@{$preconnect_buffer{$client}})
		  {
		    $outbuffer{$target_socket} .= "$line\r\n";
		  }
		delete $preconnect_buffer{$client};

	      }
	  }
      }
    delete $ready{$client};
  }

sub parse
  {
    my $line = shift;
    my ($prefix, $command, $args);
    if ($line =~ /^:(\S*) (.*)$/)
      {
	$prefix = $1;
	my $rest = $2;
	if ($rest =~ /(\S*) (.*)/)
	  {
	    $command = $1;
	    $args = $2;
	  }
	else
	  {
	    # Grmph. No arguments.
	    $command = $rest;
	  }
      }
    else
      {
	if ($line =~ /(\S*) (.*)/)
	  {
	    $command = $1;
	    $args = $2;
	  }
	else
	  {
	    # Grmph. No arguments.
	    $command = $line;
	  }
      }
    my @args = ();
    @args = split ' ', $args if defined $args;
    return ($prefix, $command, @args);
  }

sub nonblock
  {
    my $socket = shift;
    use Fcntl;

    my $flags = fcntl($socket, F_GETFL, 0)
      or die "Can't get flags for socket: $!\n";
    fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
      or die "Can't set O_NONBLOCK on socket: $!\n";
  }

sub close_socket
  {
    my $client = shift;

    delete $inbuffer{$client};
    delete $outbuffer{$client};
    delete $ready{$client};

    if (exists($name{$client}))
      {
	delete $client_name{$name{$client}};
	delete $name{$client};
      }
    delete $peer{$client} if exists $peer{$client};
    $select->remove($client);
    close $client;
  }

sub read_config
  {
    open(CONF, "proxy.rc")
      or die "Can't open proxy.rc: $!\n";
    while(my $line = <CONF>)
      {
	next if $line =~ /^\s*(\#.*)?$/; # Comments and lines containing only whitespace
	my ($name, $addr, $port) = $line =~ /(.*),(.*),(.*)/;
	$servers{$name} = {addr => $addr,
			   port => $port,
			  };
      }
    close CONF;
  }