#!/usr/bin/perl

########################################################################
# 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.                         #
########################################################################

#use 5.008;
use IO::Socket;
use IO::Select;
use Getopt::Long;
use Fcntl;
use POSIX 'setsid';
use Tie::RefHash;
use strict;

$| = 1;

########
# Main #
########

my %acl     = ();
my %traffic = ();
my %stats   = ();
my %session = ();
my %socks   = ();

tie %socks, 'Tie::RefHash';

$ENV{DEBUG}      = 0;
$ENV{LOCAL_PORT} = 5190;

my ($port, $host, $log, $acl, $daemon);
GetOptions("port=i"  => \$port,
           "host=s"  => \$host,
           "log=s"   => \$log,
           "acl=s"   => \$acl,
           "daemon"  => \$daemon);

$ENV{LOCAL_HOST} = $host   if($host);
$ENV{LOCAL_PORT} = $port   if($port);
$ENV{CFG_PORT}   = $ENV{LOCAL_PORT} + 1;
$ENV{LOG}        = $log    if($log);
$ENV{DAEMON}     = $daemon if($daemon);

unless($ENV{LOCAL_HOST}) {
    print << "EOF";

Usage: $0 --port=5190 --host=router_inner_ip

  --port=...  - local port (default: 5190)
  --host=ip   - redirector bind host
  --log=file  - log file
  --acl=file  - access list: [ALLOW|DENY] IP[/MASK], for example: 
                ALLOW 127.0.0.1/255.255.255.255
                ALLOW 127.0.0.1/32
                ALLOW 127.0.0.1
  --daemon    - enable deamonization (UNIX only)
  
  Example:
  
  your_host [192.168.0.1] -> [192.168.1.1] router/icqgate [62.40.50.3] -> [login.icq.com]
  
  icqgate.pl --port=5190 --host=192.168.1.1
  
  Explanation of the protocol:
  
  1. Send Authentication -> login.icq.com
  2. Recv AOL redir host <- login.icq.com
  3. Replace AOL redir host on router host
  
EOF

    exit;
}

daemonize() if($ENV{DAEMON});

$SIG{HUP}  = 'IGNORE';
$SIG{PIPE} = 'IGNORE';


my $server = IO::Socket::INET->new( Listen    => 10,
                                    LocalHost => $ENV{LOCAL_HOST},
                                    LocalPort => $ENV{LOCAL_PORT},
                                    Proto     => 'tcp',
                                    Type      => SOCK_STREAM,
                                    Reuse     => 1) 
             or die "Couldn't be a tcp server on port $ENV{LOCAL_PORT}: $!\n"; 

my $ipc = IO::Socket::INET->new( Listen    => 10,
                                 LocalHost => '127.0.0.1',
                                 LocalPort => $ENV{CFG_PORT},
                                 Proto     => 'tcp',
                                 Type      => SOCK_STREAM,
                                 Reuse     => 1)
             or die "Couldn't be a tcp server on port $ENV{CFG_PORT}: $!\n";

stop_blocking($server);
stop_blocking($ipc);

my $select = IO::Select->new($server, $ipc);

while($server && $ipc) 
{
  for my $client ($select->can_read(1)) 
  {
    if($client == $ipc) 
    {
      $client = $ipc->accept();
      next unless($client);

      my $sel = IO::Select->new($client);
      for($sel->can_read(3)) {
        handle_ipc($_) if($client == $_);
      }
      undef $sel;
      close($client);
    } 
    elsif($client == $server) 
    {
      $client = $server->accept();
      next unless($client);

      my $ip = get_ip($client);
      unless( $ip && check_access($ip) ) {
        close($client);
        next;
      }
      
      print_log("Accept $ip");

      my ($host, $port) = ('login.icq.com', 5190);
      
      my $sess = $session{$ip};
      if($sess) {
        $host = $sess->{host};
        $port = $sess->{port};
        delete $session{$ip};
        print_log("Delete session for $ip\nSessions: ".scalar(keys %session)."\n");
      }
      
      $traffic{$ip} = {input => 0, output => 0} unless($traffic{$ip});
      $stats{$ip}   = {} unless($stats{$ip});
      
      my $aol = connector($host, $port);
      unless($aol) {
        close($client);
        next;
      }
      
      stop_blocking($client);
      stop_blocking($aol); 
      $select->add($client);
      $select->add($aol);
      
      $socks{$client} = $aol;
      $socks{$aol}    = $client;
    } 
    else 
    {
      my %info = ();
      my $data = handler($client, \%info);
      my $out  = $socks{$client};

      my $ip = get_ip($out);
      if($ip && $traffic{$ip}) {
        $traffic{$ip}->{input} += $info{size};        
      } else {
        $ip = get_ip($client);
        $traffic{$ip}->{output} += $info{size} if($ip && $traffic{$ip});
      }

      if($ip && $traffic{$ip} && $info{uin} && defined $info{version}) {
        $stats{$ip}->{ $info{uin} } = {} unless($stats{$ip}->{ $info{uin} });
        $stats{$ip}->{ $info{uin} } = $info{version} || '-';
      }
       
      if($out && $info{uin} && $info{host} && $info{port}) {
        my $ip = get_ip($out);
        unless($ip) {
          for($out, $client) {
            next unless($_);
            $select->remove($_);
            delete $socks{$_};
            close($_);
          }
          print_log('Session failed!');
          next;
        }
        
        print_log("Create session for $ip\nSessions: ".scalar(keys %session)."\n");
        $session{$ip} = \%info;
      }
      
      unless( $data && send_data($out, $data) ) {
        my $count = scalar(keys %socks);
        for($out, $client) {
          next unless($_);
          $select->remove($_);
          delete $socks{$_};
          close($_);
        }
        my $total = scalar(keys %socks);
        $count = $count - $total;
        print_log("Clean: $count, Socks: $total");
      }
    }
  }
  
  for ($select->has_error(1)) {
    next unless($_);
    $select->remove($_);
    delete $socks{$_};
    close($_);
    print_log('Clean has_error!');
  }  
}

close($server);
close($ipc);
exit;

#################################################################################

sub connector {
  my ($host, $port) = @_;
  return undef unless($host && $port);

  print "Connect to $host:$port\n";
  my $sock = IO::Socket::INET->new( PeerHost => $host,
                                    PeerPort => $port,
                                    Proto    => 'tcp',
                                    Type     => SOCK_STREAM,
                                    Timeout  => 30,
                                    Reuse    => 1);

  print_log("Couldn't connect: $@") unless($sock);
            
  return $sock;
}

sub send_data {
  my ($sock, $data) = @_;
  return 0 unless($sock && $data);
  
  eval {
    $sock->send($data);
  };
  if($@) {
    print $@,"\n" if($ENV{DEBUG});
    print_log($@);
    
    return 0;
  }
            
  return 1;
}

sub get_ip {
  my $sock = shift;
  return undef unless($sock);
  
  my $ip = undef;
  eval {
    $ip = $sock->peerhost();
  };
  if($@) {
    print $@,"\n" if($ENV{DEBUG});
    print_log($@);
  }

  return $ip;
}

sub print_log {
  my $msg = shift;
  return unless($ENV{LOG} && $msg);

  open(OUT, ">>$ENV{LOG}") or die "Can't open '$ENV{LOG}': $!";
  print OUT $msg,"\n";
  close(OUT);
} 

sub stop_blocking {
   my ($sock) = @_;

   if($^O ne "MSWin32") {
     my $flags = fcntl($sock, F_GETFL, 0) or die "Can't get flags for socket: $!\n";
     fcntl($sock, F_SETFL, $flags | O_NONBLOCK) or die "Can't set flags for socket: $!\n";
   } else {
     # Cribbed from http://nntp.x.perl.org/group/perl.perl5.porters/42198
     my $flag = "1";
#     ioctl($sock, 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, $flag) or die "Couldn't set Win32 blocking: $!\n";
   }
}
 
sub hexdump {
    my $stuff = shift;
    
    my $retbuff = '';
    my @stuff   = ();

    return '' unless defined($stuff);
    
    for(my $i = 0; $i < length($stuff); $i++) {
        push @stuff, substr($stuff, $i, 1);
    }

    while(@stuff) {
        my $i = 0;
	$retbuff .= "\n" if($retbuff);
	my @currstuff = splice(@stuff, 0, 16);

	for my $currstuff (@currstuff) {
            $retbuff .= ' ' unless $i % 4;
	    $retbuff .= ' ' unless $i % 8;
	    $retbuff .= sprintf("%02X ", ord($currstuff));
	    $i++;
	}
	for(; $i < 16; $i++) {
	    $retbuff .= ' ' unless $i % 4;
	    $retbuff .= ' ' unless $i % 8;
	    $retbuff .= '   ';
	}

	$retbuff .= '  ';
	$i = 0;
	for my $currstuff (@currstuff) {
	    $retbuff .= ' ' unless $i % 4;
	    $retbuff .= ' ' unless $i % 8;
	    if($currstuff ge chr(0x20) and $currstuff le chr(0x7E)) {
	       $retbuff .= $currstuff;
	    } else {
	       $retbuff .= '.';
	    }
	    $i++;
	}
    }
    
    return $retbuff;
} 

sub tlv_decode {
    my ($data, $tlvcnt) = @_;

    return undef unless($data);
   
    $tlvcnt = 0 unless($tlvcnt);

    my $length = length($data);
    return undef unless($length >= 4);
            
    my %tlv     = ();
    my $currtlv = 0;
    my $strpos  = 0;
    
    while($length >= 4 and (!$tlvcnt or $currtlv < $tlvcnt)) {
       my ($type, $len) = unpack("nn", $data);
       last unless($type);

       $strpos += 4;
       substr($data, 0, 4) = '';

       $tlv{$type} = $len > 0 ? substr($data, 0, $len, '') : '';
       
       $strpos += $len;
       $currtlv++ unless($type == 0);
    }

    return \%tlv;
} 

sub tlv_encode {
    my $tlv = shift;
    
    return '' unless($tlv && ref $tlv);

    my $buffer = '';
    while( my ($type, $value) = each %$tlv ) {
    	$value ||= '';
	$buffer .= pack("nna*", $type, length($value), $value);
    }
    
    return $buffer;
}  

sub flap_decode {
    my $buf = shift;
    
    my ($id, $channel, $seq, $size) = unpack("CCnn", $buf);

    return ($id, $channel, $seq, $size);
}

sub flap_encode {
    my ($id, $channel, $seq, $data) = @_;
    
    return pack("CCnn/a*", $id, $channel, $seq, $data);
}

sub snac_decode {
    my $data = shift;
    
    return undef unless($data);
    
    my %snac = ();
    ($snac{family}, $snac{subtype}, $snac{flag}, $snac{req_id}) = unpack("nnnN", $data);
    
    return \%snac;
}

sub read_packet {
    my ($sock, $pak) = @_;

    return undef unless($sock && $pak && ref $pak);

    my $header = '';    
    my $rv  = $sock->recv($header, 6, 0);
    return undef unless(defined $rv && length($header));

    ($pak->{id}, $pak->{channel}, $pak->{seq}, $pak->{size}) = flap_decode($header);
#    print "id: $pak->{id}, channel: $pak->{channel}, seq: $pak->{seq}, size: $pak->{size}\n";
print_log("id: $pak->{id}, channel: $pak->{channel}, seq: $pak->{seq}, size: $pak->{size}\n");    
    my $data = '';
    
    if($pak->{size} > 0) {
      $rv = $sock->recv($data, $pak->{size}, 0);
 #     print "data: $data\n";
print_log("DATA: $data\n");
      return undef unless(defined $rv && length($data));
    
      if($pak->{channel} == 1) 
      {       
        $pak->{pversion} = substr($data, 0, 4);
        $pak->{tlv}      = tlv_decode(substr($data, 4));
      }
      elsif($pak->{channel} == 4)
      {
        $pak->{tlv} = tlv_decode($data);
      }
    }
                                        
    return ($header, $data);
}

sub handler {
    my ($sock, $ref) = @_;

    return undef unless($sock && $ref && ref $ref);

    my %pak  = ();
    my ($header, $data) = read_packet($sock, \%pak);

    $ref->{size} = $pak{size} ? 6 + $pak{size} : 6;

    return undef unless($header);
    
    return $header unless($data);

    if($pak{channel} == 1 && $pak{pversion}) 
    {
       $ref->{pversion} = unpack("N", $pak{pversion});

       if($ref->{pversion} == 1 && $pak{tlv}) {
         my $tlv = $pak{tlv};
         while( my ($k, $v) = each %$tlv ) {
            $ref->{uin}     = $v if($k == 1); 
            $ref->{version} = $v if($k == 3);
            $ref->{cookie}  = $v if($k == 6);
         }
         print_log("channel: 1, uin: $ref->{uin}, version[".$ref->{pversion}."]: $ref->{version}") if($ref->{uin} && $ENV{DEBUG});
       }
    } 
    elsif($pak{channel} == 4) 
    {
       if(length($data) > 0) {
          my ($uin, $addr, $cookie);
          
          my $tlv = $pak{tlv};
          while( my ($k, $v) = each %$tlv ) {
            $uin    = $v if($k == 1);
            $addr   = $v if($k == 5);
            $cookie = $v if($k == 6);
          }
          
          return undef unless($uin && $addr && $cookie);
          
          ($ref->{uin}, $ref->{cookie}) = ($uin, $cookie);
          ($ref->{host}, $ref->{port})  = split /:/ => $addr;

          print_log("channel: 4, uin: $uin, addr: $addr, host: $ref->{host}, port: $ref->{port}") if($ENV{DEBUG});
          
          $addr     = pack("nn/a*", 5, $addr);
          my $raddr = pack("nn/a*", 5, $ENV{LOCAL_HOST}.':'.$ENV{LOCAL_PORT});
          $data =~ s/$addr/$raddr/;
          
          my ($id, $channel, $seq, $size) = flap_decode($header);
          
          return flap_encode($id, $channel, $seq, $data);
       }
    }    

    return $header.$data;
}

sub parse_subnet {
  my $network = shift;

  if($network && $network =~ m/^(\d{1,3}.\d{1,3}.\d{1,3}.\d{1,3})/) {
     $network =~ s/\s+$//;
     my ($ip, $mask) = split /\// => $network;
     if($mask && ($mask =~ m/^(\d{2})$/ || $mask =~ m/^(\d{1,3}.\d{1,3}.\d{1,3}.\d{1,3})$/)) {
        $mask = $1;
     }
     return ($ip, $mask);
  }
  
  return undef;
}

sub ip2int {
  my $ip = shift;
  
  my ($a, $b, $c, $d) = split /\./ => $ip;
    
  return ($a << 24) + ($b << 16) + ($c << 8) + $d;
}

sub check_access {
  my $ip = shift;
  return 0 unless($ip);

  my @arr = sort {$acl{$a} cmp $acl{$b}} keys %acl;
  return 1 unless(@arr);

  $ip = pack('C4', split(/\./, $ip));
  
  for my $network (@arr) {
    next unless($network);
    my $access = $acl{$network};
    next unless($access && $access =~ m/^(ALLOW|DENY)/);
   
    my ($net_ip, $mask) = parse_subnet($network);
    next unless($net_ip);

    $net_ip = pack('C4', split(/\./, $net_ip));
    if($mask) {
      $mask = pack('B32', (1x$mask), (1x(32-$mask))) if($mask =~ m/^(\d{2})$/);
      $mask = pack('C4', split(/\./, $mask)) if($mask =~ m/^(\d{1,3}.\d{1,3}.\d{1,3}.\d{1,3})$/);

      if( ($ip & $mask) eq $net_ip ) {
        print_log("$ip => $network => $access") unless($access eq 'ALLOW');
        return $access eq 'ALLOW';
      }
    }
    
    if($ip eq $net_ip) {
      print_log("$ip => $network => $access") unless($access eq 'ALLOW');
      return $access eq 'ALLOW';
    }
  }
  
  return 1;
}

sub handle_ipc {
  my $sock = shift;
  return unless($sock);
  
  my $msg = '';
  my $cmd = '';
  my $rv  = $sock->recv($cmd, 255, 0);
  return unless(defined $rv && $cmd);
  
  if($cmd =~ m/^TRAFFIC/)
  {
    $msg = "IP\tINPUT\tOUTPUT\n";
    for my $ip (sort keys %traffic) {
      my $ref = $traffic{$ip};
      next unless($ref);
      $msg.= $ip."\t".$ref->{input}."\t".$ref->{output}."\n";
    }
  }
  elsif($cmd =~ m/^CLIENTS/)
  {
    $msg = "IP\tUIN\tVERSION\tCOUNT\n";    
    for my $ip (sort keys %stats) {
      my $ref = $stats{$ip};
      next unless($ref);
      for my $uin (sort keys %$ref) {
        my $v = $ref->{$uin};
        next unless($v);
        for my $version (sort keys %$v) {
          $msg.= $ip."\t".$uin."\t".$version."\t".$v->{$version}."\n";
        }
      }
    }
  }
  elsif($cmd =~ m/^STATS/)
  {
    my %clients = ();
    for(keys %socks) {
      my $ip = get_ip($_);
      next unless($ip && $traffic{$ip});
      $clients{$ip}++;
    }

    $msg = "IP\tINPUT\tOUTPUT\n";
    for my $ip (sort keys %clients) {
      my $traf = $traffic{$ip};
      next unless($traf);

      my $count = $clients{$ip} || 1;
      my ($input, $output) = ($traf->{input}, $traf->{output});
      if($count > 1) {
        $input  = int($input/$count);
        $output = int($output/$count); 
      }
      while($count) {
        $msg.= $ip."\t".$input."\t".$output."\n";
        $count--;
      }
    }
    
    $msg.= "[VERSIONS]\n";
    my %vers  = ();
    my $total = 0;
    for my $ip (sort keys %clients) {
      my $ref = $stats{$ip};
      next unless($ref);
      for my $uin (sort keys %$ref) {
        my $ver = $ref->{$uin};
        $vers{$ver}++;
        $total++;
      }
    }
    for(sort {$vers{$b} <=> $vers{$a}} keys %vers) {
      my $per = sprintf("%.2f", $total ? $vers{$_}*100/$total : 0);
      $msg.= $_."\t".$vers{$_}."\t".$per."\n";
    }
  }
  elsif($cmd =~ m/^SOCKS/)
  {
    $msg = scalar(keys %socks)."\n";
  }
  elsif($cmd =~ m/^SESSION/)
  {
    $msg = "IP\tUIN\tVERSION\n";
    for my $ip (sort keys %session) {
      next unless($ip);
      my $ref = $session{$ip};
      next unless($ref);
      $msg.= $ip."\t".($ref->{uin} || '-')."\t".($ref->{version} || '-')."\n";
    }
  }
  elsif($cmd =~ m/^LIST/) 
  {
    my @ips = sort {$acl{$a} cmp $acl{$b}} keys %acl;
    for(my $i = 0; $i < scalar(@ips); $i++) {
      $msg.= $i.') '.$acl{$ips[$i]}.' '.$ips[$i]."\n" if($ips[$i]);
    }
    $msg = 'NONE' unless($msg);
  }
  elsif($cmd =~ m/^DELETE (\d+)/)
  {
    my $i   = $1;
    my @ips = sort {$acl{$a} cmp $acl{$b}} keys %acl;
    delete $acl{$ips[$i]} if($ips[$i]);
    $msg = 'OK';
  }
  elsif($cmd =~ m/^(ALLOW|DENY)/)
  {
    my ($access, $network) = split /\s+/ => $cmd;
    
    if($network =~ m/^(\d{1,3}.\d{1,3}.\d{1,3}.\d{1,3})/) {
      $network =~ s/\s+$//;
      my ($ip, $mask) = split /\// => $network;
      if($mask && ($mask =~ m/^(\d{2})$/ || $mask =~ m/^(\d{1,3}.\d{1,3}.\d{1,3}.\d{1,3})$/)) {
        $ip.= '/'.$1;
      }      
      $acl{$ip} = $access;
      $msg = 'OK';
    }
  }
  
  $msg = 'FORMAT INVALID!' unless($msg);
  
  $sock->send($msg."\n");
}

sub url_encode {
  my $str = shift;

  $str =~ s/([^-\w@.*\s])/sprintf("%%%02X",ord($1))/ego;
  $str =~ s/ /+/gm;
  $str =~ s/%20/+/gm;
  
  return $str;
}

sub daemonize {
  return if($^O eq "MSWin32");
  print "Start daemon ...\n";
  chdir '/'                 or die "Can't chdir to /: $!";
  open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
  open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
  defined(my $pid = fork) or die "Can't fork: $!";
  exit if $pid;
  setsid or die "Can't start a new session: $!";
  #open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
}