# $Id$

# Rocco's IRC bot stuff.

package Client::IRC;

use strict;

use POE::Session;
use POE::Component::IRC;
use Util::Message;

use Util::Conf qw(SCALAR LIST REQUIRED);

Util::Conf->associate_type_with_schema(
  benchbot => {
    irc => {
      name      => SCALAR | REQUIRED,
      server    => LIST   | REQUIRED,
      nick      => SCALAR | REQUIRED,
      uname     => SCALAR | REQUIRED,
      iname     => SCALAR | REQUIRED,
      away      => SCALAR | REQUIRED,
      flags     => SCALAR | REQUIRED,
      quit      => SCALAR | REQUIRED,
      cver      => SCALAR | REQUIRED,
      cuinfo    => SCALAR | REQUIRED,
      ccinfo    => SCALAR | REQUIRED,
      channel   => LIST   | REQUIRED,
      ignore    => LIST,
      localaddr => SCALAR,
    },
  }
);

my $conf = Util::Conf->read(&main::CONF_FILE, "benchbot");

sub send_message {
  my $message = Util::Message->new(shift);
  Server::Backends->send($message);
}

#------------------------------------------------------------------------------
# Spawn the IRC session(s).

foreach my $network ($conf->get_names_by_type('irc')) {
  my %conf = $conf->get_items_by_name($network);

  # Translate the ignore list into a hash.
  my %ignore = { map { lc() => 1 } @{$conf{ignore}} };

  POE::Component::IRC->new($network);

  POE::Session->create(
    inline_states => {
      _default            => \&on_all_else,
      _start              => \&bot_start,
      autoping            => \&bot_autoping,
      backend_response    => \&bot_respond,
      connect             => \&bot_connect,

      irc_001             => \&on_connect,
      irc_ctcp_action     => \&on_messages,
      irc_ctcp_clientinfo => \&on_ctcp_clientinfo,
      irc_ctcp_userinfo   => \&on_ctcp_userinfo,
      irc_ctcp_version    => \&on_ctcp_version,
      irc_disconnected    => \&on_disconnect,
      irc_error           => \&on_error,
      irc_invite          => \&on_invite,
      irc_join            => \&on_join,
      irc_kick            => \&on_kick,
      irc_mode            => \&on_mode,
      irc_msg             => \&on_private,
      irc_nick            => \&on_nick,
      irc_notice          => \&on_messages,
      irc_part            => \&on_part,
      irc_pong            => \&on_pong,
      irc_public          => \&on_messages,
      irc_quit            => \&on_quit,
      irc_socketerr       => \&on_disconnect,
      irc_snotice         => \&on_snotice,
      irc_topic           => \&on_topic,
      join                => \&bot_join,
    },
    args => [ $network, \%conf, \%ignore ],
  );
}

# Actions.

sub bot_start {
  my ($kernel, $session, $heap, $network, $conf, $ignore) =
    @_[KERNEL, SESSION, HEAP, ARG0..ARG2];

  $heap->{network} = $network;
  $heap->{conf}    = $conf;
  $heap->{ignore}  = $ignore;

  $kernel->alias_set("irc_client_$network");
  $kernel->post($network => register => 'all');

  # For server rotation.
  $heap->{server_index} = 0;

  # Keep-alive timer.
  $kernel->delay(autoping => 300);

  # Start connecting.
  $kernel->yield('connect');
}

sub bot_autoping {
  my ($kernel, $heap) = @_[KERNEL, HEAP];
  $kernel->post($heap->{network} => userhost => $heap->{conf}{nick})
    unless $heap->{seen_traffic};
  $heap->{seen_traffic} = 0;
  $kernel->delay(autoping => 300);
}

sub bot_connect {
  my ($kernel, $heap) = @_[KERNEL, HEAP];

  $kernel->post(
    $heap->{network} => connect => {
      Debug     => 0,
      Nick      => $heap->{conf}{nick},
      Server    => $heap->{conf}{server}->[$heap->{server_index}],
      Port      => 6667,
      Username  => $heap->{conf}{uname},
      Ircname   => $heap->{conf}{iname},
      LocalAddr => $heap->{conf}{localaddr},
    }
  );

  $heap->{server_index}++;
  $heap->{server_index} = 0
    if $heap->{server_index} >= @{$heap->{conf}{server}};
}

sub bot_join {
  my ($kernel, $heap, $channel) = @_[KERNEL, HEAP, ARG0];
  $heap->{seen_traffic} = 1;

  if ($channel =~ /^(\S+)\s+(\S+)/) {
    $kernel->post($heap->{network} => join => $1, $2);
  }
  else {
    $kernel->post($heap->{network} => join => $channel);
  }
}

sub bot_respond {
  my ($kernel, $heap, $response) = @_[KERNEL, HEAP, ARG0];

  my $responses = $response->responses();
  return unless defined $responses and ref($responses) eq "ARRAY";

  foreach (@$responses) {
    my ($type, @stuff) = @$_;

    if ($type eq "say" or $type eq "act") {
      my $text = join " ", @stuff;
      $text = chr(1) . "ACTION $text" . chr(1) if $type eq "act";

      my $dest = $response->channel();
      $dest = $response->nick() unless defined $dest;

      if (ref($dest) eq "ARRAY") {
        $dest = join ",", @$dest;
      }

      $kernel->post($response->network() => privmsg => $dest => $text);
      next;
    }

    if ($type eq "do") {
      $kernel->post($response->network() => @stuff);
      next;
    }

    warn "Unknown message type($type) stuff(@stuff)";
  }
}

# Reactions.

sub on_all_else {
  my ($kernel, $heap, $event, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
  $heap->{seen_traffic} = 1;

  $args ||= [ ];
  print "default: $event (@$args)\n";
  return 0;
}

sub on_private {
  my ($kernel, $heap, $actor, $recipients, $message) =
    @_[KERNEL, HEAP, ARG0..ARG2];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  # Ignore certain users.
  return if exists $heap->{ignore}{$nick};

  my $my_nick = $heap->{conf}{nick};
  my @csrecipients = (
    map { lc($_) eq lc($my_nick) ? $csnick : $_ } @$recipients
  );

  # Gracefully handle multiple recipients?
  my $csrecipients;
  if (@csrecipients > 1) {
    $csrecipients = join ",", @csrecipients;
  }
  else {
    $csrecipients = $csrecipients[0];
  }

  my @recipients = map { lc } @csrecipients;
  my $recipients = lc($csrecipients);

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      message   => $message,
      channel   => $recipients,
      cschannel => $csrecipients,

      chanarray => \@recipients,
      cschanarray => \@csrecipients,

      addressed => 1,
    }
  );
}

sub on_messages {
  my ($kernel, $heap, $actor, $channel, $message) =
    @_[KERNEL, HEAP, ARG0..ARG2];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  # Ignore certain users.
  return if exists $heap->{ignore}{$nick};

  # Gracefully handle multiple channels?
  my $cschannel;
  if (@$channel > 1) {
    $cschannel = join ",", @$channel;
  }
  else {
    $cschannel = $channel->[0];
  }

  my @channel = map { lc } @$channel;

  # Determine whether we were addressed.
  my $addressed;
  my $self = $heap->{conf}{nick};
  $addressed = 1 if $message =~ s/^\s*$self[\#\)\-\:\>\}\|\,]+\s*//;

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      message   => $message,
      channel   => lc($cschannel),
      cschannel => $cschannel,

      chanarray => \@channel,
      cschanarray => $channel,

      addressed => $addressed,
    }
  );
}

sub on_connect {
  my ($kernel, $heap) = @_[KERNEL, HEAP];
  $heap->{seen_traffic} = 1;

  if (defined $heap->{conf}{flags}) {
    $kernel->post(
      $heap->{network} => mode => $heap->{conf}{nick} => $heap->{conf}{flags}
    );
  }

  $kernel->post($heap->{network} => away => $heap->{conf}{away});

  foreach my $channel (@{$heap->{conf}{channel}}) {
    $kernel->yield(join => $channel);
  }

  # Why do we reset the server index?
  $heap->{server_index} = 0;

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},
    }
  );
}

sub on_ctcp_version {
  my ($kernel, $heap, $actor) = @_[KERNEL, HEAP, ARG0];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  $kernel->post(
    $heap->{network} => ctcpreply => $nick, "VERSION $heap->{conf}{cver}"
  );

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      addressed => 1,
    }
  );
}

sub on_ctcp_clientinfo {
  my ($kernel, $heap, $actor) = @_[KERNEL, HEAP, ARG0];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  $kernel->post(
    $heap->{network} => ctcpreply => $nick, "CLIENTINFO $heap->{conf}{ccinfo}"
  );

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      addressed => 1,
    }
  );
}

sub on_ctcp_userinfo {
  my ($kernel, $heap, $actor) = @_[KERNEL, HEAP, ARG0];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  $kernel->post(
    $heap->{network} => ctcpreply => $nick, "USERINFO $heap->{conf}{cuinfo}"
  );

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      addressed => 1,
    }
  );
}

sub on_invite {
  my ($kernel, $heap, $actor, $channel) = @_[KERNEL, HEAP, ARG0, ARG1];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  $kernel->yield(join => $channel);

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      channel   => lc($channel),
      cschannel => $channel,
      addressed => 1,
    }
  );
}

sub on_kick {
  my ($kernel, $heap, $actor, $channel, $kickee, $message) =
    @_[KERNEL, HEAP, ARG0..ARG4];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      message   => $message,
      kickee    => lc($kickee),
      cskickee  => $kickee,

      channel   => lc($channel),
      cschannel => $channel,
      addressed => 1,
    }
  );
}

sub on_disconnect {
  my ($kernel, $heap, $server) = @_[KERNEL, HEAP, ARG0];
  $heap->{seen_traffic} = 1;
  $kernel->delay(connect => 60);

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},
    }
  );
}

sub on_error {
  my ($kernel, $heap, $message) = @_[KERNEL, HEAP, ARG0];
  $heap->{seen_traffic} = 1;
  $kernel->delay( connect => 60 );

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      message   => $message,

      addressed => 1,
    }
  );
}

sub on_nick {
  my ($kernel, $heap, $actor, $new_nick) = @_[KERNEL, HEAP, ARG0, ARG1];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      newnick   => lc($new_nick),
      csnewnick => $new_nick,

      addressed => 1,
    }
  );
}

sub on_join {
  my ($kernel, $heap, $actor, $channel) = @_[KERNEL, HEAP, ARG0, ARG1];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      channel   => lc($channel),
      cschannel => $channel,
      addressed => 1,
    }
  );
}

sub on_quit {
  my ($kernel, $heap, $actor, $message) = @_[KERNEL, HEAP, ARG0, ARG1];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      message   => $message,

      addressed => 1,
    }
  );
}

sub on_part {
  my ($kernel, $heap, $actor, $channel) = @_[KERNEL, HEAP, ARG0, ARG1];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      channel   => lc($channel),
      cschannel => $channel,
      addressed => 1,
    }
  );
}

sub on_pong {
  my ($kernel, $heap, $actor, $cookie) = @_[KERNEL, HEAP, ARG0, ARG1];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      cookie    => $cookie,
      addressed => 1,
    }
  );
}

sub on_mode {
  my ($kernel, $heap, $actor, $modee, $modes, $operands) =
    @_[KERNEL, HEAP, ARG0..ARG3];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      modee     => lc($modee),
      csmodee   => $modee,
      modes     => $modes,
      operands  => $operands,

      addressed => 1,
    }
  );
}

sub on_snotice {
  my ($kernel, $heap, $message) = @_[KERNEL, HEAP, ARG0];
  $heap->{seen_traffic} = 1;

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      message   => $message,
    }
  );
}

sub on_topic {
  my ($kernel, $heap, $actor, $channel, $topic) = @_[KERNEL, HEAP, ARG0..ARG2];
  $heap->{seen_traffic} = 1;
  my ($csnick) = $actor =~ /^([^!@]+)/;
  my ($nick, $ident, $host) = split(/[!@]/, lc($actor));

  send_message(
    {
      network   => $heap->{network},
      protocol  => "irc",
      event     => ($_[STATE] =~ /^(irc_)?(.+)$/)[1],
      mynick    => lc($heap->{conf}{nick}),
      csmynick  => $heap->{conf}{nick},

      actor     => lc($actor),
      csactor   => $actor,
      nick      => $nick,
      ident     => $ident,
      host      => $host,
      csnick    => $csnick,

      topic     => $topic,

      channel   => lc($channel),
      cschannel => $channel,
      addressed => 1,
    }
  );
}

1;