package MConnection::Telnet;
use strict;
use vars qw(
  @ISA
  $ListenSocket
  
  %CmdName
  %OptName
  
  %TempErr
  %LostErr
  %BadErr
);

use IO::Socket qw();

use MCoreTools;
use MConnection;
use MIOManager;
@ISA = qw(MConnection MInitializable);

### Constants and constant variables ##########################################

use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use POSIX qw(:errno_h);

# log message options
use constant TEL_DEBUG => 0;
use constant TEL_ERROR => 1;

# misc constants
use constant LISTEN_QUEUE => 5;
use constant CONNECTION_TIMEOUT => 600;

BEGIN {
  %CmdName = map {/^\d/ ? chr($_) : $_} (
      0 => 'IS'  ,
      1 => 'SEND',
    239 => 'EOR' , # end of record
    240 => 'SE'  , # subnegotiation end
    241 => 'NOP' ,
    242 => 'DM'  , # Data Mark - not implemented
    243 => 'BRK' , # Break - not implemented
    244 => 'IP'  , # Interrupt Process
    245 => 'AO'  , # Abort output - not implemented
    246 => 'AYT' , # Are You There
    247 => 'EC'  , # Erase character
    248 => 'EL'  , # Erase Line
    249 => 'GA'  , # go ahead
    250 => 'SB'  , # subnegotiation begin
    251 => 'WILL', # \
    252 => 'WONT', #  \ option negotiation 
    253 => 'DO'  , #  /
    254 => 'DONT', # /
    255 => 'IAC' , # Interpret As Command
  );
  foreach (keys %CmdName) {
    eval "sub $CmdName{$_} () {qq{\\x" . sprintf('%02x', ord($_)) . "}}";
  }
  # any opts without comments here are completely ignored, and listed only to provide their names in log messages
  %OptName = map {/^\d/ ? chr($_) : $_} (
     0 => 'TRANSMIT-BINARY',
     1 => 'ECHO',                # used fake
     3 => 'SUPPRESS-GO-AHEAD',   # supported by server, not requested
     5 => 'STATUS',
     6 => 'TIMING-MARK',
    22 => 'SUPDUP-OUTPUT',
    24 => 'TERMINAL-TYPE',       # requested by server
    25 => 'END-OF-RECORD',       # supported by server, not requested
    31 => 'NAWS',                # requested by server
    33 => 'TOGGLE-FLOW-CONTROL',
    34 => 'LINEMODE',
  );
  foreach (keys %OptName) {
    my $name = $OptName{$_};
    $name =~ tr/-/_/;
    eval "sub OPT_$name () {chr(" . ord($_) . ")}";
  }
}

# temporary errors - try again later
%TempErr = map {eval($_) => $_} qw(EAGAIN EWOULDBLOCK EINTR);

# other end disconnected errors - disconnect
%LostErr = map {eval($_) => $_} qw(ENOTCONN ECONNRESET EPIPE);

# something went wrong errors - disconnect
%BadErr  = map {eval($_) => $_} qw(EBADF EFBIG EINVAL EIO EISDIR ENOSPC ERANGE ENXIO);

# for some reason MacPerl occasionally has a system call fail with $! == 0
$TempErr{0} = 'no error??';

### Class methods #############################################################

sub _initialize {
  my ($class) = @_;
  initialize MConnection;
  initialize MIOManager;
  MConnection->register_listener($class);

  MDefList->root->get('States')->add('CORE', 'telnet_initial_wait' => {input => sub {}, timeout => 2});
}

sub _listen_start {
  my ($class) = @_;

  my ($addr, $port) = $::Config{'socket'} =~ /(\w+(?:\.\w+)*)?:(\d+)/;
  $addr ||= '';
  mudlog "Opening listener on $addr:$port...";
  $port or die "Bad format in addr/port specification (\$::Config{socket})";
  $ListenSocket = new IO::Socket::INET (
    ($addr ? (LocalAddr => $addr) : ()),
    LocalPort => $port,
    Proto     => 'tcp',
    Listen    => LISTEN_QUEUE,
    (!IS_MACOS ? (Reuse => 1) : ()),
  ) or die "Can't create listener: $!\n";
  # About Reuse => 1:
  # This is somewhat dangerous (see http://www.faqs.org/faqs/unix-faq/socket/),
  # but I don't think this server will be confused too much by unwanted data.
  # MacPerl seems to not like having Reuse true, therefore the conditional

  MIOManager->add($ListenSocket, 'read', MEvent::Message->new(target => $class, method => '_listen_accept'));
  fcntl($ListenSocket, F_SETFL, fcntl($ListenSocket, F_GETFL, 0) | O_NONBLOCK) or mudlog "Error setting nonblocking mode on listener: $!";
}

sub _listen_stop {
  my ($class) = @_;

  $ListenSocket->close if $ListenSocket;
  undef $ListenSocket;
}

sub _listen_accept {
  my ($class) = @_;

  if (my $newsock = $ListenSocket->accept) {
    $class->new($newsock)->setstate('telnet_initial_wait');
  } else {
    mudlog "ERROR/IO: telnet listener accept() failed: $!"
      unless $! == EWOULDBLOCK or $! == 0;
  }
}

### Instance methods: Initialization ##########################################

sub _subnew {
  my ($self, $sock) = @_;

  $self->{sock} = $sock;
  $self->{telopt_my_sent} = {};
  $self->{telopt_your_sent} = {};
  $self->{telopt_my} = {};
  $self->{ip} = join '.', unpack 'C4', $sock->peeraddr;
  $self->{port} = $sock->peerport;

  $self->id_log("from $self->{ip}:$self->{port}");

  MIOManager->add($sock, 'read', MEvent::Message->new(target => $self, method => '_read_input', no_store => 1));

  $sock->timeout(CONNECTION_TIMEOUT);

  # O_NONBLOCK should be inherited from the listener, but just to make sure (and in case telnet sockets somehow get created otherwise), we set it explicitly
  fcntl($sock, F_SETFL, fcntl($sock, F_GETFL, 0) | O_NONBLOCK) or $self->id_log("ERROR/IO: Error setting nonblocking mode: $!");

  $self->send_telopt(DO,OPT_TERMINAL_TYPE);
  $self->send_telopt(DO,OPT_NAWS);
}  

sub disconnect {
  my $self = shift;
  
  $self->SUPER::disconnect(@_);
  if ($self->{sock}) {
    MIOManager->remove($self->{sock});
    $self->{sock}->close;
  }
}

### Instance methods: Subclass overrides ######################################

# In order to produce NO echo at all, we promise the client that we'll
# do the echo, and don't do it.
sub send_echo_off   {$_[0]->send_telopt(WILL,OPT_ECHO)}
sub send_echo_on    {$_[0]->send_telopt(WONT,OPT_ECHO)}
sub send_incomplete {
  if ($_[0]{telopt_my}{(OPT_END_OF_RECORD)}) {
    $_[0]->send_to_socket(IAC.EOR);
  } else {
    $_[0]->send_to_socket(IAC.GA) unless $_[0]->{telopt_my}{(OPT_SUPPRESS_GO_AHEAD)};
  }
}

sub send_str_raw { # this is the main link from MConnection
  my ($self, $t) = @_;
  
  $t =~ s/\n/\015\012/g;
  $t =~ s/\xFF/\xFF\xFF/g; # escape IACs
  $self->send_to_socket($t);
}

sub open {$_[0]->{sock} ? 1 : 0}
sub source {$_[0]->{ip} && $_[0]->{port} ? "$_[0]->{ip}:$_[0]->{port}" : "n/a"}
sub il_source {''}

sub do_timeout {
  my $self = shift;

  if ($self->{state} eq 'telnet_initial_wait') {
    $self->setstate('login'); # FIXME
  } else {
    $self->SUPER::do_timeout(@_);
  }
}

sub do_timeout_warning {
  my $self = shift;
  $self->SUPER::do_timeout_warning(@_) unless $self->{state} eq 'telnet_initial_wait';
}

### Instance methods: Socket IO ###############################################

# socket_error: based on the value of $!, returns 0 if the error is temporary,
# or disconnects the connection and returns 1 if the error will recur on
# another IO operation.
sub socket_error {
  my ($self, $was_doing) = @_;
  
  return 0 if $TempErr{0+$!};
  $self->disconnect(($LostErr{0+$!} ? "lost connection: $LostErr{0+$!}"
                   : $BadErr{0+$!}  ? "internal $was_doing error: $BadErr{0+$!} $!"
                                    : "unknown $was_doing error: ".(0+$!)." $!"), 1)
}

sub send_to_socket {
  my ($self, $t) = @_;

  my $s = $self->{sock} or return;

  if ($self->{syswrite_buffer}) {
    # if there's a buffer, then that means the socket's not ready
    # for writing, so we append the text to the buffer
    $self->{syswrite_buffer} .= $t;
    return 1;
  }

  my $len = syswrite $s, $t, length($t);
  if (!defined $len) {
    $self->socket_error('write') and return;
    $len = 0;
  }
  if ($len < length($t)) {
    $self->{syswrite_buffer} = substr($t, $len);
    MIOManager->add($s, 'write', MEvent::Message->new(target => $self, method => '_flush_syswrite', no_store => 1));
  }
  return;
}

sub _flush_syswrite {
  my ($self) = @_;
  my $t = $self->{syswrite_buffer};
  delete $self->{syswrite_buffer};
  MIOManager->remove($self->{sock}, 'write');
  $self->send_to_socket($t);
}

### Instance methods: Telnet protocol #########################################

sub send_telopt {
  my ($self, $cmd, $opt) = @_;
  $self->send_to_socket(IAC.$cmd.$opt);
  $self->{($cmd eq DO || $cmd eq DONT) ? 'telopt_your_sent' : 'telopt_my_sent'}{$opt}++;
  $self->id_log("Telnet: Sending option $CmdName{$cmd} $OptName{$opt}") if TEL_DEBUG;
}

sub _telopt_handler {
  my ($self, $tbuf, $cmd, $cname, $ohandlers) = @_;
  length($$tbuf) >= 3 or return 0;
  my $opt = substr($$tbuf, 2, 1);
  substr($$tbuf, 0, 3) = '';
  my $is_my = ($cmd eq DO || $cmd eq DONT);
  my $statekey = $is_my ? 'telopt_my_sent' : 'telopt_your_sent';
  if ($self->{$statekey}{$opt}) {
    # we sent the request, this is a response for it
    $self->id_log("Got $cname in response to option ".($OptName{$opt} || ord($opt))) if TEL_DEBUG;
    if ($is_my) {
      $self->{telopt_my}{$opt} = ($cmd eq DO);
      $self->_telopt_my_new_state($opt, ($cmd eq WILL));
    } else {
      $self->_telopt_their_new_state($opt, ($cmd eq WILL));
    }
    $self->{$statekey}{$opt}--; # might be dangerous. once got an infinite DONT/WONT loop when using = 0 instead of --
  } else {
    # we didn't send a request, this is a client-initiated sequence
    $self->id_log("Got $cname client-initiated for option ".($OptName{$opt} || ord($opt))) if TEL_DEBUG;
    &{$ohandlers->{$opt} || sub {
      $self->send_to_socket(IAC.DONT.$opt) if $cmd eq WILL or $cmd eq WONT;
      $self->send_to_socket(IAC.WONT.$opt) if $cmd eq DO   or $cmd eq DONT;
      $self->id_log("Unsupported option code ".($OptName{$opt} || ord($opt))." in $cname") if TEL_ERROR;
    }};
  }
  1;
}

sub _telopt_their_new_state {
  my ($self, $opt, $state) = @_;
  return unless $opt eq OPT_TERMINAL_TYPE and $self->state eq 'telnet_initial_wait';
  if ($state) {
    $self->id_log("Sending terminal type request.") if TEL_DEBUG;
    $self->send_to_socket(IAC.SB.OPT_TERMINAL_TYPE.SEND.IAC.SE); # whew
  } else {
    $self->id_log("Refused to discuss terminal type.") if TEL_DEBUG;
    $self->setstate('login'); # FIXME
  }
}

sub _telopt_my_new_state {
  my ($self, $opt, $state) = @_;
  # no special handling needed
}

sub _read_input {
  my ($self) = @_;
  
  my $tbuf = \$self->{telnet_buffer};

  {
    my $res = sysread $self->{sock}, my($tx), 4096;
    defined $res or $self->socket_error('read'), return;
    length $tx or $self->disconnect('socket closed'), return;
  
    $$tbuf .= $tx;
  }

  mudlog "Telnet: DEBUG $self->{id} tel_buffer=" . unpack('H*', $$tbuf) if TEL_DEBUG and $$tbuf;

  # first handle all the codes we can...
  # any 'last' means that the code was incomplete, so we wait till we recieve
  # enough data that it's complete.
  TCODE: while ((my $ipos = index $$tbuf, IAC) >= 0) {
  
    # dump text preceding IAC into input buffer, so we
    # process the telnet code in the right place in the data stream.
    $self->{in_buffer} .= substr($$tbuf, 0, $ipos);
    substr($$tbuf, 0, $ipos) = '';
    
    # at this point the bytes in $$tbuf are IAC, command number, ...
    
    last TCODE if length($$tbuf) < 2; # skip if there's no command code
    my $icmd = substr $$tbuf, 1, 1;
    #$self->id_log("Telnet: got command ".($CmdName{$icmd} || ord($icmd))) if TEL_DEBUG;
    # If one of these command handlers returns false, that means that
    # it determined that the command is incomplete, and therefore
    # processing of the input will be delayed until the necessary
    # data is received.
    &{{
      (IAC) => sub {
        substr($$tbuf, 0, 2) = '';
        $self->{in_buffer} .= IAC;
      },
      (SB) => sub {
        my $sub_end = index $$tbuf, IAC.SE;
        $sub_end != -1 or return 0;
        my $sub_code = substr($$tbuf, 2, 1);
        my $sub_data = substr($$tbuf, 3, $sub_end - 3);
        $self->id_log("Telnet: Got SB ".($OptName{$sub_code} || ord($sub_code))) if TEL_DEBUG;
        $sub_data =~ s/\xFF{2}/\xFF/g; # fix escaped IACs
        &{{
          (OPT_NAWS) => sub {
            my ($hsize, $vsize) = unpack 'nn', $sub_data;
            $self->id_log("Telnet: Received window size info: $hsize x $vsize") if TEL_DEBUG;
            $self->pref(scr_width => $hsize);
            $self->pref(scr_height => $vsize);
          },
          (OPT_TERMINAL_TYPE) => sub {
            my $mode = substr($sub_data, 0, 1);
            return unless $mode eq IS;
            substr($sub_data, 0, 1) = '';
            $self->id_log("Telnet: Received terminal type: $sub_data") if TEL_DEBUG;
            $self->{terminal_type} = $sub_data;
            
            $self->pref(no_ansi => 1) unless $sub_data =~ /^(?:VT\d+|XTERM|ANSI)$/;
            $self->setstate('login') if $self->{state} eq 'telnet_initial_wait'; # FIXME
          },
        }->{$sub_code} || sub {$self->id_log("Telnet: Unrecognized subnegotiation code ".ord($sub_code)) if TEL_ERROR}};
        substr($$tbuf, 0, $sub_end + 2) = '';
        1;
      },
      (WILL) => sub {_telopt_handler($self, $tbuf, WILL, 'WILL', {
        (OPT_SUPPRESS_GO_AHEAD) => sub {$self->send_to_socket(IAC.DO.OPT_SUPPRESS_GO_AHEAD)},
        (OPT_NAWS) => sub {$self->send_to_socket(IAC.DO.OPT_NAWS)},
        (OPT_TERMINAL_TYPE) => sub {$self->send_to_socket(IAC.DO.OPT_TERMINAL_TYPE)},
      })},
      (WONT) => sub {_telopt_handler($self, $tbuf, WONT, 'WONT', {
        (OPT_NAWS) => sub {$self->send_to_socket(IAC.DONT.OPT_NAWS)},
        (OPT_TERMINAL_TYPE) => sub {$self->send_to_socket(IAC.DONT.OPT_TERMINAL_TYPE)},
      })},
      (DO  ) => sub {_telopt_handler($self, $tbuf, DO, 'DO', {
        (OPT_SUPPRESS_GO_AHEAD) => sub {$self->send_to_socket(IAC.WILL.OPT_SUPPRESS_GO_AHEAD); $self->{telopt_my}{(OPT_SUPPRESS_GO_AHEAD)} = 1;},
        (OPT_TIMING_MARK) => sub {$self->send_to_socket(IAC.WONT.OPT_TIMING_MARK)},
        (OPT_NAWS) => sub {$self->send_to_socket(IAC.WONT.OPT_NAWS)},
        (OPT_TERMINAL_TYPE) => sub {$self->send_to_socket(IAC.WONT.OPT_TERMINAL_TYPE)},
      })},
      (DONT) => sub {_telopt_handler($self, $tbuf, DONT, 'DONT', {
      })},
      (AYT) => sub {
        substr($$tbuf, 0, 2) = '';
        $self->send_str("\n[Yes, $::Config{name} is still running.]\n");
        1;
      },
      (IP) => sub {
        substr($$tbuf, 0, 2) = '';
        1;
      },
      (EC) => sub {
        substr($$tbuf, 0, 2) = '';
        $self->{in_buffer} .= "\b";
        #$self->force_prompt;
        1;
      },
      (EL) => sub {
        substr($$tbuf, 0, 2) = '';
        print "DEBUG: in buffer is <<$self->{in_buffer}>>\n";
        if ($self->{in_buffer} =~ s/([\r\n]|^)[^\r\n]+[\r\n]*$/$1/) {
          $self->send_str("\n[Cancelled line.]\n");
          $self->force_prompt;
        }
        1;
      },
      (GA) => sub {substr($$tbuf, 0, 2) = ''; 1},
      (BRK) => sub {substr($$tbuf, 0, 2) = ''; 1},
    }->{$icmd} || sub {substr($$tbuf, 0, 2) = ""; $self->id_log("Telnet: Unknown command ".($CmdName{$icmd} || ord($icmd))) if TEL_ERROR;1}}
      or last TCODE;
    # unrecognized codes get zapped.
  }
  # don't dump over the text if there turns out to be a incomplete code.
  unless ((index $$tbuf, IAC) >= 0) {
    $$tbuf =~ s/\cM\cJ?|\cJ/\n/g;
    $self->{in_buffer} .= $$tbuf;
    $$tbuf = '';
  }

  $self->handle_input;
  return 1;
}

1;
