#!/usr/bin/perl

use strict;
my $version = "0.0.2";
&log("whoisd $version for xs26 by yanek startup...");

# whoisd for XS26.net
# yanek <yanek@bofh.cz> (c) 2002 
# GPL

# Config
#print " - Loading config\n";
use vars qw (%config);

&log("- Setting config defaults");

do 'whoisd-config' or die "Cannot load whoisd-config, buddy. $!";

&log(" - Setting variables");

# Sets variables

# Load perl's libraries
&log(" - Loading perl's libraries");
use Data::Dumper; # debug
use IO::Select;
#use IO::Socket;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); # non-block IO
use Socket;
use Socket6;
use DBI;

# Set autoflush
$| = 1;

# Bind SIGs
&log(" - Setting SIGnals");
$SIG{TERM} = \&botdie;
$SIG{ALRM} = \&botdie;
$SIG{INT} = \&botdie;

# Create socket list
&log(" - Create socket list");
my $select = new IO::Select( );

# Bind to listen port
if (!$config{'ipv6notbind'}) {
  &log(" - Binding listen port ipv6");

  my $proto = getprotobyname('tcp');
  socket(Server, AF_INET6, SOCK_STREAM, $proto)       || die "socket: $!";
  setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", $config{'connectmax'})) || die "setsockopt: $!";
  bind(Server, sockaddr_in6($config{'port'}, inet_pton(PF_INET6, "::")))        || die "bind: $!";
  listen(Server,SOMAXCONN)                            || die "listen: $!";
  { my $oldfh = select(Server); $| = 1; select($oldfh); }
  $select->add( \*Server );
}

if ($config{'ipv4extrabind'}) {
  &log(" - Binding listen port ipv4");

  my $proto = getprotobyname('tcp');
  socket(Server2, AF_INET, SOCK_STREAM, $proto)       || die "socket: $!";
  setsockopt(Server2, SOL_SOCKET, SO_REUSEADDR, pack("l", $config{'connectmax'})) || die "setsockopt: $!";
  bind(Server2, sockaddr_in($config{'port'}, inet_aton("0.0.0.0")))        || die "bind: $!";
  listen(Server2,SOMAXCONN)                            || die "listen: $!";
  { my $oldfh = select(Server2); $| = 1; select($oldfh); }
  $select->add( \*Server2 );
}    

# MySQL connection
&log(" - Establishing connection to MySQL");
my $dbpath = sprintf("DBI:mysql:database=%s;host=%s",$config{'mysql-database'},$config{'mysql-host'});
my $sql = DBI->connect($dbpath,$config{'mysql-user'},$config{'mysql-pass'}); #, {'RaiseError' => 1});

my ($dcc,$input,$idxi,$ridx,$idx);
# core loop
&log(" - Going to loop, wait for incoming connection");

&demonize_me if $config{daemonize};


my $mainloop = 1;
while ($mainloop) {
  my @ready = $select->can_read(1);
  foreach my $fh (@ready) {
    if (!$config{'ipv6notbind'} && (\*$fh == \*Server)) { # Create a new incoming socket
      my $new;
      accept($new,*$fh) or (warn "accept(...): $!\n" and next);
      $select->add( $new);
      fcntl($new, F_SETFL, O_NONBLOCK) or die "Can't set flags for the socket: $!\n";
      { my $old = select($new); $| = 1; select($old); }
      print $new "$config{'motd'}\n";
      $dcc->{$new}->{'state'} = 1;
      $dcc->{$new}->{'idx'} = &getfreeidx($new);
      $dcc->{$new}->{'type'} = 6;
      my $rso = getpeername($new);
      my ($peerport,$peeraddr) = unpack_sockaddr_in6($rso);
      $peeraddr = &inet_ntop(AF_INET6, $peeraddr);
            
      &log(" - - [%s] New connection (AF_INET6) ([%s]:%s)",
        $dcc->{$new}->{'idx'},
        $peeraddr,
        $peerport);
    }
    elsif ($config{'ipv4extrabind'} && (\*$fh == \*Server2)) { # Create a new incoming socket
      my $new;
      accept($new,*$fh) or (warn "accept(...): $!\n" and next);
      $select->add( $new);
      fcntl($new, F_SETFL, O_NONBLOCK) or die "Can't set flags for the socket: $!\n";
      { my $old = select($new); $| = 1; select($old); }
      print $new "$config{'motd'}\n";
      $dcc->{$new}->{'state'} = 1;
      $dcc->{$new}->{'idx'} = &getfreeidx($new);
      $dcc->{$new}->{'type'} = 4;

      my $rso = getpeername($new);
      my ($peerport,$peeraddr) = sockaddr_in($rso);
      $peeraddr = inet_ntoa($peeraddr);
            
      &log(" - - [%s] New connection (AF_INET) ([%s]:%s)",
        $dcc->{$new}->{'idx'},
        $peeraddr,
        $peerport);
    }
    else { # Process socket
      my $r = read($fh,my $data,2048);
      my @a = getpeername($fh) || warn "a: $!";
      
      if (defined $r and $a[0]) {
        $input->{$fh} .= $data;
        my $idx = $dcc->{$fh}->{idx};
        if ($idx) { 
          $idxi->{$idx}->{idle} = scalar time;
          my @d = split(/\n/,$input->{$fh});
          my $next = pop(@d);
          if ($input->{$fh} =~ /(\n|\r)$/) {
            push(@d,$next);
            $next = undef;
          }
          foreach (@d) {
            $data = &strip($_);
            &log(" * * C0re[$idx]: '$data'") if $config{debug};
            &parse_it($fh,$idx,$data);
          }
          $input->{$fh} = ($next ? $next : undef);
        } else {
          warn "Whau!\n";
          print Dumper($dcc,$fh);
        }
      } else {
        &socket_die($fh);
      }

    }
  }
# System timers
#  foreach my $a (@stimers) {

#  }
# User timers
#  foreach my $a (@timers) {

}

sub botdie {
  &log("Received die, cleaning...");
  foreach $a ($select->handles) {
    close($a);
  }
  close(Server);
  &log("OK. Exit");
  exit;
}

sub socket_die {
  my $fh = shift;
  &log(" - - [$ridx->{$fh}] Socket disconnected");
  $idx->{$ridx->{$fh}} = undef;
  $ridx->{$fh} = undef;
  $select->remove($fh);
  $dcc->{$fh} = undef;
  close($fh);
  return 0;
}
sub getfreeidx { # return first free idx
  my $socket = shift;
  for(my $i = 1; $i < $config{'connectmax'}; ++$i) {
    if (!$idx->{$i}) {
      $idx->{$i} = $socket;
      $idxi->{$i}->{io} = $socket;
      $ridx->{$socket} = $i;
      return $i;
    }
  }
  die "Max. connections reached";
}
#sub putidx {
#  my ($toidx,$data) = @_;
#  my $out = $idx->{$toidx};
#  print $out "$data\n";
#}

sub putidx {
   my ($toidx,$form,@values) = (@_,'','','');
   &putidxf($toidx,$form."\r\n",@values);
}

sub putidxf {
   my ($toidx,$form,@values) = @_;
   if ($toidx == 0) { warn "!!! IDX can be zero value !!! ($toidx,$form,(".&strip(join(", ",@values))."))"; }
   my $data = (@values ? sprintf($form, @values) : $form);
   my $out = $idxi->{$toidx}->{io};
#   print 'PUTIDX ',$toidx," )$out( ",&strip($data);
#   print Dumper($out);
   my @a = getpeername($out);
                     
   if ($out and defined $a[0]) {
      syswrite($out,$data,length $data);
      return 1;
   }
   if (defined $out) { &socket_die($out); }
   return 0;
}

sub strip {
  my $a = shift;
  $a =~ s/\r//g;
  $a =~ s/\n//g;
  return $a;
}
sub reply {  my $a = shift; my $b = shift; &putidx($a,"%-14s%s",$b.':', @_);  }

sub log {
   my ($form,@values) = (@_,'','');
   &logf($form."\r\n",@values);
}

sub logf {
   my ($form,@values) = @_;
   my $data = '['.(scalar localtime).'] '.(@values ? sprintf($form, @values) : $form);
   print STDERR $data;
}

sub reformatzone {
  my $zone = shift;
  $zone =~ s/(....)/$1:/g;
  my @zone1;
  foreach (split(':',$zone)) {
    s/^0+//g;
    push(@zone1,$_);
  }
  my $zone2 = join(":",@zone1);
  $zone2 =~ s/\:{2,}/::/g;
  return $zone2;
}

sub reformatzone2 {
  my $zone = shift;
  my @zone1;
  foreach (split(/:/,$zone)) {
    push(@zone1,('0' x (4 - length($_))).$_);
  }
  my $zone2 = join('',@zone1);
  return $zone2.('0' x (32 - length($zone2)));
}

sub reformatzone3 {
  my ($zone,undef,$prefix) = $_[0] =~ /([^\/]*)(\/(.*))?/; my ($s) = 0;
  if (!$prefix) { #compute prefix
    $prefix ||= 128; $s = 1;
  }
  return (unpack("H*", pack("B*", ('1' x $prefix) . ('0' x (128 - $prefix))
        & unpack("B*", pack("H*", &reformatzone2($zone)))))) . (!$s ? '/' . $prefix : '');
}

sub demonize_me ($) {
  my $pidfile = shift;
#  &log("Daemonizing...");
  defined (my $pid = fork) or die "Can't fork: $!";
  if ($pid) { exit; }
  else {
    require 'POSIX.pm';
    &POSIX::setsid or die "Can't start a new session: $!";
    open STDOUT,'>/dev/null' or die "ERROR: Redirecting STDOUT to /dev/null: $!";
    open STDERR,'>/dev/null' or die "ERROR: Redirecting STDERR to /dev/null: $!";
    open STDIN, '</dev/null' or die "ERROR: Redirecting STDIN from /dev/null: $!";
  }
}

....snip....