#!/usr/bin/perl -w

use strict;

use Socket;
use Symbol;
use Carp;

# central config info
my %config =
  (
   name => "Tkil's test server", # name of this talker
   host => "slinky.scrye.com",	# name of this machine
   port => 2112,		# port to listen on
   owner => "tkil",		# user to get godlike privs
   tick => 5,			# timeout, in seconds
   DEBUG => 1
  );

# what sockets are listening in?
my @listeners;

# translate between users and sockets.  this is a hash-of-hashes, to
# allow for more than one socket per user (yet still offer fast
# lookups).
my %sockets_of_user;

# xref between sockets and FD numbers (used by 4-arg select()) i was
# considering using an array here, but some systems (notabley Win32)
# don't always use small FDs.  note that we don't need a matching
# %fd_of_socket, since that can always be found with the fileno()
# function.
my %socket_of_fd;

# this hash holds most of the information about a given connection.
# the outer/primary key will be the socket handle itself (which gets
# stringified); the inner keys will be:
#
#    socket -- the actual socket reference
#    user -- name of user on this conneciton
#    host -- FQDN of host the connection is coming from
#    ip -- ip address (ascii dotted-quad notation) of remote host
#    port -- remote port
#    state -- what state is the connection in?  (see SS_ constants below)
#    user_tries -- how many attempts to get valid username?
#    pw_tries -- how many attempts to get valid password? (see MAX_AUTH_TRIES)
#
my %socket_info;

# use for $socket_info{$sock}{pw_tries} and user_tries
use constant MAX_AUTH_TRIES => 3;

# for $socket_info{$sock}{state}
use constant SS_NEED_USERNAME => 0; # just connected, need username
use constant SS_NEED_PASSWORD => 1; # have valid username, need password
use constant SS_CONNECTED     => 2; # normal
use constant SS_CLOSE_PENDING => 3; # socket is done, write any leftover data
use constant SS_CLOSE_IMMED   => 4; # socket is dead/error, just kill it

# and buffers for i/o
my %read_buf;
my %write_buf;
use constant SOCK_IO_SIZE => 1024;
use constant CRLF => "\015\012";

# passwords
my %password_for_user = 
  ( 
   "tkil" => "test",
   "mariah" => "bouncy",
   "hiccups" => "kendal",
   "veblen" => "geek",
  );

# what priveleges do different users have?
my %user_privs;
use constant UP_LISTEN_ONLY => 0;
use constant UP_NORMAL      => 1;
use constant UP_GODLIKE     => 2;

# some bit vectors used to "select()" between the different sockets.
my ($rin, $win) = (chr(0), chr(0)); 
# very important to NOT set these to 0, since that becomse stringified
# and makes the initial state be 0x30 instead of 0x00...

# and a bit of state:
use constant SERV_NORMAL => 0;
use constant SERV_CLOSE_PENDING => 1;
use constant SERV_CLOSE_IMMED => 2;

my $server_state = SERV_NORMAL;

# ============================================================

sub read_config
{
}


# ============================================================

sub find_sockets_in_state
{
  my $target_state = shift;

  return 
    map { $_->{socket} } 
      grep { $_->{state} == $target_state }
        values %socket_info;
}

# ============================================================

sub parse_normal_line
{
  my ($sock, $line) = @_;
  my $user = $socket_info{$sock}{user};

  # if it starts with a slash, it's special; otherwise it's not.
  if ($line =~ m@^/@)
  {
    my ($command, $rest) = split ' ', $line, 2;
    $command = substr $command, 1; # remove leading slash
    if ($command eq "me")
    {
      broadcast("* $user $rest", CRLF);
      return;
    }
    elsif ($command eq "users")
    {
      my $users = join " ", map { $_->{user} } values %socket_info;
      write_to_socket($sock, $users, CRLF);
      return;
    }
    elsif ($command eq "quit")
    {
      write_to_socket($sock, "nice seeing you", CRLF);
      $socket_info{$sock}{state} = SS_CLOSE_PENDING;
      return;
    }
    elsif ($command eq "msg")
    {
      my ($dest, $msg) = split ' ', $rest, 2;
      print STDERR qq[msg: from *$user* -> *$dest*: "$msg"\n]
	if $config{DEBUG} > 1;
      $msg .= CRLF;
      if (exists $sockets_of_user{$dest})
      {
	foreach my $dest_sock (values %{$sockets_of_user{$dest}})
	{
	  write_to_socket($dest_sock, "*$user* $msg");
	  write_to_socket($sock, "-> *$dest* $msg")
	}
      }
      else
      {
	write_to_socket($sock, "*** $dest is not connected right now", CRLF);
      }
      return;
    }
    elsif ($command eq "shutdown")
    {
      my $t = localtime;

      unless ($user eq $config{owner})
      {
	print STDERR "*** attempted /SHUTDOWN by $user at $t ***\n";
	write_to_socket($sock, "sorry, only the owner can do a /shutdown", CRLF);
	return;
      }

      print STDERR "\n*** SHUTDOWN by $user at $t ***\n";

      # tell everyone good-bye
      foreach my $si (values %socket_info)
      {
	write_to_socket($si->{socket}, "*** shutdown by $user, bye!", CRLF);
	$si->{state} = SS_CLOSE_PENDING;
      }

      $server_state = SERV_CLOSE_PENDING;
      return;
    }
    else
    {
      write_to_socket($sock, "*** unknown command /$command", CRLF);
      return;
    }
  }
  else
  {
    # normal line, just echo it to all users.
    broadcast("<$user> $line", CRLF);
  }
}

# ============================================================

sub write_to_socket
{
  my $sock = shift;

  croak "bad socket" unless $sock;

  # add the text to the output buffer
  $write_buf{$sock} .= join "", @_;

  if ($config{DEBUG} > 1)
  {
    my $fd = fileno($sock);
    my $text = $write_buf{$sock};
    $text =~ s/\015/<CR>/g;
    $text =~ s/\012/<LF>/g;
    print STDERR "\nwts: adding fd $fd to win, buf=\"$text\"\n";
  }

  # and mark it as "needs to be written to"
  vec($win, fileno($sock), 1) = 1;
}

# ============================================================

sub broadcast
{
  my $text = join "", @_;
  my @connected_sockets = find_sockets_in_state(SS_CONNECTED);

  foreach my $s (@connected_sockets)
  {
    write_to_socket($s, $text);
  }
}

# ============================================================

sub handle_line
{
  my ($sock, $line) = @_;
  # chomp $line;
  $line =~ s/\s+\Z//;

  use vars '%info';
  local (*info) = $socket_info{$sock};

  if ($info{state} == SS_NEED_USERNAME)
  {
    # now we know who it is...
    if (exists $password_for_user{$line})
    {
      $info{user} = $line;
      $sockets_of_user{$line}{$sock} = $sock;

      # and we can prompt for a password
      write_to_socket($sock, "Password: ");

      # we don't care about user tries anymore:
      delete $info{user_tries};

      # keep track of the number of password tries.
      $info{pw_tries} = 0;

      # and shift to the next state
      $info{state} = SS_NEED_PASSWORD;
    }
    else
    {
      # user doesn't seem to exist.  have we tried enough yet?
      ++$info{user_tries};
      if ($info{user_tries} >= MAX_AUTH_TRIES)
      {
	$info{state} = SS_CLOSE_IMMED;
	return;
      }

      # no, let them try again.
      write_to_socket($sock, "No such user \"$line\".", CRLF, "Username: ");
    }
  }
  elsif ($info{state} == SS_NEED_PASSWORD)
  {

    # these values are guaranteed to exist, see above
    my $user     = $info{user};
    my $password = $password_for_user{$user};

    print STDERR
      qq[authenticating "$user": expecting "$password", got "$line"\n]
	if $config{DEBUG} > 1;

    if ($line eq $password)
    {
      write_to_socket($sock, "Welcome, $user", CRLF);
      $info{state} = SS_CONNECTED;
      broadcast("*** $user has joined from $info{host} ***", CRLF);
      return;
    }
    else
    {
      ++$info{pw_tries};
      print STDERR "pw_tries for $user: $info{pw_tries}\n";
      if ($info{pw_tries} >= MAX_AUTH_TRIES)
      {
	$info{state} = SS_CLOSE_IMMED;
	return;
      }
      write_to_socket($sock, "Invalid Password", CRLF, "Password: ");
      return;
    }
  }
  elsif ($info{state} <= SS_CLOSE_PENDING)
  {
    parse_normal_line($sock, $line);
  }
}

# ============================================================

sub add_socket
{
  my ($sock, $packed_addr) = @_;

  # get the file descriptor
  my $fd = fileno $sock;

  # add it to the listening pools
  vec($rin, $fd, 1) = 1;
  vec($win, $fd, 1) = 1;

  # and add to the translation hash
  $socket_of_fd{$fd} = $sock;

  # get hostname.
  my ($port, $iaddr) = unpack_sockaddr_in($packed_addr);
  my $host = gethostbyaddr($iaddr, AF_INET);
  my $ip_num = inet_ntoa($iaddr);
  $socket_info{$sock} = { socket => $sock,
			  host => $host,
			  ip => $ip_num,
			  port => $port,
			  state => SS_NEED_USERNAME,
			  user_tries => 0 };

  if ($config{DEBUG})
  {
    my ($host, $port, $ip) = map $socket_info{$sock}{$_}, qw(host port ip);
    print STDERR "accepting connection from $host:$port ($ip)\n"
      if $config{DEBUG} > 1;
  }

  # set up socket state
  $read_buf{$sock} = "";
  $write_buf{$sock} = "Welcome to $config{name}.  Username: ";
}

# ============================================================

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

  return unless defined $sock;

  my $user = $socket_info{$sock}{user};
  broadcast("*** $user is leaving ***", CRLF);

  # get the file descriptor
  my $fd = fileno $sock;

  # remove it from the select() pools.
  vec($rin, $fd, 1) = 0;
  vec($win, $fd, 1) = 0;

  if ($config{DEBUG} > 1)
  {
    my ($host, $port) = map $socket_info{$sock}{$_}, qw(host port);
    print STDERR "\nclosing connection from $user ($host:$port)\n";
  }

  # remove it from translation hash
  delete $socket_of_fd{$fd};

  # remove it from the list of sockets that a user is connected from.
  delete $sockets_of_user{$user}{$sock};

  # if this was the last socket for that user, delete the whole entry.
  unless (keys %{ $sockets_of_user{$user} })
  {
    delete $sockets_of_user{$user};
  }

  # clean up socket state
  delete $read_buf{$sock};
  delete $write_buf{$sock};

  # forget about it
  delete $socket_info{$sock};

  # and begone!
  close $sock;
}

# ============================================================
# main program

# do setup stuff
read_config();

# set up the listening port
my $proto = getprotobyname("tcp");
my $listen_sock = gensym();
socket($listen_sock, PF_INET, SOCK_STREAM, $proto)
  or die "couldn't create listen socket: $!";
my $port = $config{port};
my $host = $config{host};
my $iaddr = inet_aton($host);
my $saddr_in = sockaddr_in($port, $iaddr);
bind($listen_sock, $saddr_in)
  or die "couldn't bind listen socket: $!";
listen($listen_sock, SOMAXCONN)
  or die "couldn't listen on listen socket: $!";

# main loop setup
my $tick = $config{tick};
my $listen_fd = fileno($listen_sock);
vec($rin, $listen_fd, 1) = 1;

print STDERR "listening on $config{host}:$config{port}\n";

if ($config{DEBUG} > 1) {
  print STDERR "Passwords:\n";
  while (my ($k, $v) = each %password_for_user) {
    print qq[  "$k" => "$v"\n];
  }
}

MAIN:
while ($server_state != SERV_CLOSE_IMMED)
{

  # see if we can get one more go-around
  if ($server_state == SERV_CLOSE_PENDING)
  {
    $server_state = SERV_CLOSE_IMMED;
  }

  if ($config{DEBUG} > 1)
  {
    print STDERR
      "\nabout to select: rin=0x", unpack("H*", $rin),
      ", win=0x", unpack("H*", $win), 
      "; server_state=$server_state\n";
  }

  # listen to all our sockets for anything interesting
  my ($r, $w, $n, $remain);
  ($n, $remain) = select($r = $rin, $w = $win, undef, $tick);

  # did select return successfully?
  unless (defined $n && $n >= 0)
  {
    die "select returned an error (n=$n): $!";
  }

  if ($config{DEBUG} > 1) {
    print STDERR
      "select returned n=$n",
      ", r=0x", unpack("H*", $r),
      ", w=0x", unpack("H*", $w), "\n";
  }

  # did nothing happen?
  if ($n == 0)
  {
    print STDERR "." if $config{DEBUG};
    $tick = $config{tick};
    next MAIN;
  }

  # check for new connections
  if (vec($r, $listen_fd, 1))
  {
    my $new_sock = gensym();
    my $packed_addr = accept $new_sock, $listen_sock;
    if ($packed_addr)
    {
      add_socket($new_sock, $packed_addr);
      print STDERR "+" if $config{DEBUG};
    }
    else
    {
      print STDERR "!" if $config{DEBUG};
    }
    vec($r, $listen_fd, 1) = 0;
  }

  # ==== handle writes ====
 WRITE_DATA:
  for (my $i = 0; $i < length($w)*8; ++$i)
  {
    # can we write to this socket yet?
    next WRITE_DATA unless vec($w, $i, 1);

    # we need the actual socket name
    my $sock = $socket_of_fd{$i};

    # anything to write?
    next WRITE_DATA unless $write_buf{$sock};

    print STDERR "W($i)" if $config{DEBUG} > 1;

    my $buf = $write_buf{$sock};
  WRITE_BUF:
    while ($buf)
    {
      my $n_written = syswrite($sock, $buf, SOCK_IO_SIZE);
      if (not defined $n_written)
      {
	warn "syswrite biffed: $!";
	# since it errored now, i don't think we want to really try again.
	$socket_info{$sock}{state} = SS_CLOSE_IMMED;
	last WRITE_BUF;
      }
      else
      {
	$buf = substr($buf, $n_written);
	print STDERR "w" if $config{DEBUG};
      }
    }
    $write_buf{$sock} = $buf;

    # remove this socket from the "need to write" set, unless
    # something is still in $buf.  [there shouldn't be...]
    vec($win, $i, 1) = 0 unless $buf;
  }

  # ==== read new data ====
 READ_DATA:
  for (my $i = 0; $i < length($r)*8; ++$i)
  {
    # does this particular fd have anything to say?
    next READ_DATA unless (vec($r, $i, 1) && exists $socket_of_fd{$i});

    print STDERR "R($i)" if $config{DEBUG} > 1;

    # get the actual socket
    my $sock = $socket_of_fd{$i};
    # and anything we had left over from last time
    my $buf = $read_buf{$sock};

    my $n_bytes_read = sysread($sock, $buf, SOCK_IO_SIZE, length $buf);
    if (not defined $n_bytes_read)
    {
      print STDERR "sysread returned error: $!";
      $socket_info{$sock}{state} = SS_CLOSE_IMMED;
    }
    elsif ($n_bytes_read == 0)
    {
      # if we didn't read any more bytes, then we probably want to remove it.
      $socket_info{$sock}{state} = SS_CLOSE_PENDING;
    }
    else
    {
      # split the buffer on newlines...
      my @lines = split /\n/, $buf, -1;
      # ... saving any stragglers for the next time around
      $buf = pop @lines;

      # and then process each line.
      foreach (@lines)
      {
	handle_line($sock, $_);
	print STDERR "r" if $config{DEBUG};
      }
    }

    # store the remnants for the next time around.
    $read_buf{$sock} = $buf;
  }

  # any sockets to remove?
  my @sockets_to_remove = find_sockets_in_state(SS_CLOSE_IMMED);
  foreach (@sockets_to_remove)
  {
    remove_socket($_);
    print STDERR "-";
  }

  # to avoid loops when we have an error on write, we'll just
  # "downgrade" all pending closes to immediate closes.  this is a
  # hack.  the "clean" way to do this would be to keep track of
  # whether we've already tried to write the data back.... i think.
  foreach (values %socket_info)
  {
    $_->{state} = SS_CLOSE_IMMED
      if $_->{state} == SS_CLOSE_PENDING;
  }

  # we got interrupted.  might as well try to be consistent.
  $tick = $remain;
}

close $listen_sock;
print STDERR "\n";

exit;