The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl
package IO::Multiplex::Intermediary::Client;
use Moose;
use namespace::autoclean;

use IO::Socket;
use IO::Select;
use Time::HiRes qw(gettimeofday);
use JSON;

local $| = 1;

has socket => (
    is         => 'rw',
    isa        => 'IO::Socket::INET',
    lazy_build => 1,
    clearer    => 'clear_socket',
);

sub _build_socket {
    my $self = shift;
    my $socket = IO::Socket::INET->new(
        PeerAddr => $self->host,
        PeerPort => $self->port,
        Proto    => 'tcp',
    ) or die $!;

    return $socket;
}

has host => (
    is      => 'ro',
    isa     => 'Str',
    lazy    => 1,
    default => 'localhost',
);

has port => (
    is      => 'ro',
    isa     => 'Int',
    lazy    => 1,
    default => 9000
);

has read_set => (
    is         => 'ro',
    isa        => 'IO::Select',
    lazy_build => 1,
);

has remaining_usecs => (
    is      => 'rw',
    isa     => 'Int',
    default => 1_000_000,
);

sub _build_read_set {
    my $self = shift;
    my $select = IO::Select->new;

    $select->add($self->socket);
    return $select;
}

sub parse_input {
    my $self  = shift;
    my $input = shift;

    $input =~ s/[\r\n]*$//s;
    my @inputs = grep { $_ } split /\e/m, $input;
    for (@inputs) {
        my $output = $self->parse_json($_);
        $self->socket->send("$output\n\e");
    }
};

sub build_response {
    my $self     = shift;
    my $wheel_id = shift;
    my $input    = shift;

    return $input;
}

sub connect_hook {
    my $self   = shift;
    my $data   = shift;

    return to_json({param => 'null'});
}

sub input_hook {
    my $self   = shift;
    my $data   = shift;

    return to_json(
        {
            param => 'output',
            data => {
                value => $self->build_response(
                    $data->{data}->{id},
                    $data->{data}->{value}
                ),
                id => $data->{data}->{id},
            }
        }
    );
}

sub disconnect_hook {
    my $self   = shift;
    my $data   = shift;

    my $id = $data->{data}->{id};

    return to_json(
        {
            param => 'disconnect',
            data  => {
                success => 1,
            },
        }
    );
}

sub parse_json {
    my $self = shift;
    my $json = shift;
    my $data = eval { from_json($json) };

    if ($@) { warn $@; return }

    my %actions = (
        'connect'    => sub { $self->connect_hook($data)    },
        'input'      => sub { $self->input_hook($data)      },
        'disconnect' => sub { $self->disconnect_hook($data) },
    );

    return $actions{ $data->{param} }->()
        if exists $actions{ $data->{param} };


    return to_json({param => 'null'});
}

sub force_disconnect {
    my $self = shift;
    my $id = shift;
    my %args = @_;

    my $output = to_json +{
        param => 'disconnect',
        data => {
            id => $id,
            %args,
        }
    };

    $self->socket->send("$output\n\e");
}

sub send {
    my $self = shift;
    my ($id, $message) = @_;

    my $output = to_json +{
        param => 'output',
        data => {
            value => $message,
            id    => $id,
        }
    };

    #warn "[C Sends]: $output";
    $self->socket->send("$output\n\e");
}

sub multisend {
    my $self = shift;
    my %ids  = @_;

    my $packet = q[];
    while (my ($id, $message) = each %ids) {
        $packet .= to_json +{
            param => 'output',
            data => {
                value => $message,
                id    => $id,
            },
        };

        $packet .= "\n\e";
    }

    #warn "[C Sends]: $output";
    $self->socket->send($packet);
}

sub tick {
    # stub
}

sub cycle {
    my $self = shift;

    my $sec_fraction = $self->remaining_usecs / 1_000_000;
    my @sockets_available = $self->read_set->can_read($sec_fraction);
    foreach my $fh (@sockets_available) {
        my $buf = <$fh>;
        return 0 unless defined $buf;
        $self->parse_input($buf);
    }

    my ($secs, $usecs) = gettimeofday;
    my $remaining      =   1_000_000 - $usecs;

    $remaining ||= 1_000_000;
    $self->remaining_usecs($remaining);

    $self->tick unless @sockets_available;

    return 1;
}

sub run {
    my $self = shift;
    1 while $self->cycle;
}

__PACKAGE__->meta->make_immutable;

1;

__END__

=head1 NAME

IO::Multiplex::Intermediary::Client - base controller for the server

=head1 SYNOPSIS

    package Controller;
    use Moose;
    extends 'IO::Multiplex::Intermediary';

    around build_response => sub {
        my $orig = shift;
        my $self = shift;

        my $response = $self->$orig(@_);

        return rot13($response);
    };

    around connect_hook => sub {
        my $orig = shift;
        my $self = shift;
        my $data = shift;

        $players{ $data->{data}{id} } = new_player;

        return $self->$orig(@_);
    };

    around input_hook => sub {
        my $orig = shift;
        my $self = shift;

        return $self->$orig(@_);
    };

    around disconnect_hook => sub {
        my $orig   = shift;
        my $self   = shift;
        my $data   = shift;

        delete $player{ $data->{data}{id} };
        return $self->$orig($data, @_);
    };

=head1 DESCRIPTION

B<WARNING! THIS MODULE HAS BEEN DEEMED ALPHA BY THE AUTHOR. THE API
MAY CHANGE IN SUBSEQUENT VERSIONS.>

The flow of the controller starts when an end connection sends a
command.  The controller figures out who sent the command and relays
it to the logic that reads the command and comes up with a response
(Application).

   Connections
       |
       v
     Server
       ^
       |
       V
     Client
       ^
       |
       v
  Application

=head1 ATTRIBUTES

This module supplies you with these attributes which you can pass to
the constructor as named arguments:

=over

=item C<host>

This attribute is for the host on which the server runs.

=item C<port>

This attribute is for the host on which the server runs on.

=back

=head1 METHODS

=over

=item C<run>

Starts the client, which connects to the intermediary and waits for
input to respond to.

=item C<send($id, $message)>

Tells the intermediary to output C<$message> to the user with the ID
C<$id>.

=item C<multisend($id =E<gt> $message, $id =E<gt> $message, ...)>

Tells the intermediary to output various messages to its corresponding
IDs.

=back

=head1 HOOKS

These are internal methods with the primary purposes of hooking from
the outside for a more flexible and extensive use.

=over

=item C<build_response>

This hook is a method that you want to hook for doing your response
handling and output manipulateion (see the L</SYNOPSIS> section).  As the
method stands, C<build_response> returns exactly what was input to
the method, making the application a simple echo server.

=item C<connect_hook>

This hook runs after a user connects. It returns JSON data that
tells the intermediary that it has acknowledge the user has
connected.

=item C<input_hook>

This hook runs after the intermediary sends an input request. It
returns a JSON output request which contains the response build by
C<build_response>.

=item C<disconnect_hook>

This hook runs after a user disconnects. It has the same behavior
as the C<connect_hook> method, just with disconnect information.

=item C<tick>

This hook runs on the second every second. By itself, it is does
not do anything. Hooking from other applications is its only purpose.

=back

=head1 AUTHOR

Jason May <jason.a.may@gmail.com>

=head1 LICENSE

This library is free software and may be distributed under the same
terms as perl itself.

=cut