The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Convos::Loopback;

=head1 NAME

Convos::Loopback - Loopback connection

=head1 DESCRIPTION

This class represents a loopback connection. That is a connection which is
only visible internally to convos, and thus does not require a IRC server.

This module must be compatible with L<Mojo::IRC>.

=head1 SYNOPSIS

  my $connection = Convos::Core::Connection->new(....);
  my $loopback = Convos::Loopback->new(connection => $connection);

  $loopback->connect(sub {
    my($loopback, $error) = @_;
    # ...
  });

=cut

use Mojo::Base -base;
use constant DEBUG => $ENV{MOJO_IRC_DEBUG} ? 1 : 0;

=head1 ATTRIBUTES

=head2 server

Cannot be set. Will always return "loopback".

=head2 name

The name of this IRC client. Defaults to "Convos".

=head2 nick

Holds the nick.

=head2 pass

Exists for L<Mojo::IRC> compat reasons.

=head2 tls

Exists for L<Mojo::IRC> compat reasons.

=head2 user

Alias for L</nick>.

=cut

has name => 'Convos';
has nick => '';
has 'pass';
sub server {'loopback'}
sub tls    {undef}
sub user   { shift->nick }

=head2 ioloop

Holds an instance of L<Mojo::IOLoop>.

=head2 redis

Holds an instance of L<Mojo::Redis>.

=cut

has ioloop => sub { shift->redis->ioloop };
has redis  => sub { shift->connection->redis };

=head2 connection

Holds and instance of L<Convos::Core::Connection>. Must be provided in
constructor.

=cut

sub connection { shift->{connection} }

=head1 METHODS

=head2 new

Used to create a new object. L</connection> is required parameter.

=cut

sub new {
  my $self = Mojo::Base::new(@_);
  $self->{connection} or die 'connection is required';
  $self->{debug_key} = join ':', $self->server, $self->user;
  Scalar::Util::weaken($self->{connection});
  $self;
}

=head2 change_nick

Used to change L</nick>.

=cut

sub change_nick {
  my ($self, $nick) = @_;
  my $old = $self->nick // '';

  return $self unless defined $nick;
  return $self if $old and $old eq $nick;
  $self->_register_nick($nick, sub { });
  $self;
}

=head2 connect

  $self->connect($cb);

Will start subscribing to messages sent to this nick.

=cut

sub connect {
  my ($self, $cb) = @_;

  if ($self->{connected}) {
    return $self->$cb('');
  }

  $self->{debug_key} = join ':', $self->server, $self->user;
  $self->_register_nick(
    $self->nick,
    sub {
      my ($self, $new, $old) = @_;
      $self->connection->irc_rpl_welcome({});
      $self->$cb('');
    }
  );

  Scalar::Util::weaken($self);
  $self->{messages} = $self->redis->subscribe("convos:loopback");
  $self->{messages}->on(
    message => sub {
      my $message = Parse::IRC::parse_irc($_[1]);
      my $method  = lc('irc_' . ($message->{command} || 'error'));
      my $nick    = $self->nick;

      warn "[$self->{debug_key}] >>> $_[1] ($method)\n" if DEBUG;

      return $self->connection->$method($message)   if $self->connection->can($method);
      return $self->connection->irc_error($message) if $method =~ m/^irc_err/i;
    }
  );

  $self;
}

sub _register_nick {
  my ($self, $new, $cb) = @_;
  my $old = $self->nick;

  $self->_redis_execute(
    [sismember => "convos:loopback:names", $new],
    sub {
      my ($self, $taken) = @_;

      return $self->_register_nick($new . '_', $cb) if $taken;
      $self->redis->sadd("convos:loopback:names", $new);
      $self->_nick_changed($old, $new);
      $self->$cb($new, $old);
    }
  );
}

sub _nick_changed {
  my ($self, $old, $new) = @_;

  if ($old ne $new) {
    delete $self->{conversation}{$old};
    $self->_publish("NICK :$new");
    $self->redis->srem("convos:loopback:names", $old);
    $self->redis->zrange(
      $self->connection->{conversation_path},
      0, -1,
      sub {
        my ($redis, $conversations) = @_;
        for ($self->connection->channels_from_conversations($conversations)) {
          $redis->srem("convos:loopback:$_:names", $old);
          $redis->sadd("convos:loopback:$_:names", $new);
        }
      }
    );
  }

  $self->nick($new);
  $self->{conversation}{$new} = $self->redis->subscribe("convos:loopback:$new");
  $self->{conversation}{$new}->on(message => sub { $self and $self->_message_from($new, $_[1]) });
}

sub _publish {
  my ($self, $message) = @_;
  $self->redis->publish("convos:loopback", sprintf(':%s!~%s\@loopback %s', $self->nick, $self->nick, $message),);
}

=head2 disconnect

Does nothing.

=cut

sub disconnect {shift}

=head2 write

See L<Mojo::IRC/write>.

=cut

sub write {
  my $cb   = ref $_[-1] eq 'CODE' ? pop : sub { };
  my $self = shift;
  my $cmd  = join ' ', @_;
  my $nick = $self->nick;
  my ($method, @args);

  if ($cmd =~ /^:$nick (\w+)\s?(.*)/) {
    $method = $1;
    @args = split ' ', $2;
  }
  else {
    ($method, @args) = split ' ', $cmd;
  }

  if ($method = $self->can(lc "_write_$method")) {
    $self->$method(@args)->$cb('');
  }
  else {
    $self->$cb("Unknown command: $cmd");
  }
}

sub _message_from {
  my ($self, $target, $message) = @_;
  my $sender = $message =~ s/^:(\w+)\s// ? $1 : $self->nick;
  return if $sender eq $self->nick;
  return $self->connection->add_message({params => [$target, $message], prefix => "$sender\@loopback",});
}

sub _write_join {
  my ($self, $channel) = @_;

  Scalar::Util::weaken($self);
  $self->{conversation}{$channel} = $self->redis->subscribe("convos:loopback:$channel");
  $self->{conversation}{$channel}->once(
    data => sub {
      $self->redis->sadd("convos:loopback:$channel:names", $self->nick);
      $self->_publish("JOIN $channel");
    }
  );
  $self->{conversation}{$channel}->on(
    message => sub {
      $self and $self->_message_from($channel, $_[1]);
    }
  );

  $self;
}

sub _write_names {
  my ($self, $channel) = @_;

  $self->_redis_execute(
    [smembers => "convos:loopback:$channel:names"],
    sub {
      my ($self, $names) = @_;
      $self->connection->irc_rpl_namreply({params => ['', '', $channel, join ' ', @$names]});
    }
  );
}

sub _write_nick {
  my ($self, $new) = @_;
  my $old = $self->nick;

  $new or return;
  $self->_redis_execute(
    [sadd => "convos:loopback:names", $new],
    sub {
      my ($self, $added) = @_;

      if ($added) {
        $self->_nick_changed($old, $new);
        $self->connection->cmd_nick({params => [$new]});
      }
      else {
        $self->connection->irc_error({params => ['Nickname is already in use']});
      }
    }
  );
}

sub _write_part {
  my ($self, $channel) = @_;
  my $nick = $self->nick;

  $self->_redis_execute(
    [srem => "convos:loopback:$channel:names", $self->nick],
    sub {
      my ($self, $parted) = @_;
      $self->_publish("PART $channel");
    }
  );
}

sub _write_privmsg {
  my ($self, $target, @msg) = @_;

  local $" = ' ';
  $msg[0] =~ s/^://;
  $self->redis->publish("convos:loopback:$target", sprintf ':%s %s', $self->nick, "@msg");
}

sub _write_topic {
  my ($self, $channel, @topic) = @_;
  my $topic = join ' ', @topic;

  if ($topic) {
    $topic =~ s/^://;
    $self->_redis_execute(
      [hset => "convos:loopback:$channel", "topic", $topic],
      sub {
        my ($self) = @_;
        $self->_publish("TOPIC $channel :$topic");
      }
    );
  }
  else {
    $self->_redis_execute(
      [hget => "convos:loopback:$channel", "topic"],
      sub {
        my ($self, $topic) = @_;
        $self->connection->irc_rpl_topic({params => ['', $channel, $topic // '']});
      }
    );
  }
}

sub _redis_execute {
  my $cb   = pop;
  my $self = shift;

  Scalar::Util::weaken($self);
  $self->redis->execute(@_, sub { shift; $self and $self->$cb(@_) });
  $self;
}

=head1 AUTHOR

Jan Henning Thorsen - C<jhthorsen@cpan.org>

=cut

1;