File Coverage

blib/lib/POE/Component/IRC/Plugin/Proxy.pm

Criterion	Covered	Total	%
statement	148	179	82.6
branch	35	56	62.5
condition	16	30	53.3
subroutine	24	28	85.7
pod	4	12	33.3
total	227	305	74.4

package POE::Component::IRC::Plugin::Proxy;
our $AUTHORITY = 'cpan:HINRIK';
$POE::Component::IRC::Plugin::Proxy::VERSION = '6.92';
use strict;
use warnings FATAL => 'all';
use Carp;
use Socket qw(inet_ntoa);
use POE qw(Wheel::SocketFactory Wheel::ReadWrite Filter::IRCD
           Filter::Line Filter::Stackable);
use POE::Component::IRC::Plugin qw(PCI_EAT_NONE);

sub new {
    my ($package) = shift;
    croak "$package requires an even number of arguments" if @_ & 1;
    my %args = @_;
    $args{ lc $_ } = delete $args{ $_ } for keys %args;
    return bless \%args, $package;
}

sub PCI_register {
    my ($self, $irc) = splice @_, 0, 2;

    if (!$irc->isa('POE::Component::IRC::State')) {
        die __PACKAGE__ . ' requires PoCo::IRC::State or a subclass thereof';
    }

    $irc->raw_events(1);
    $self->{irc} = $irc;
    $irc->plugin_register(
        $self,
        'SERVER',
        qw(
            connected
            disconnected
            001
            error
            socketerr
            raw
        )
    );

    POE::Session->create(
        object_states => [
            $self => [qw(
                _client_error
                _client_flush
                _client_input
                _listener_accept
                _listener_failed
                _start
                _shutdown
                _spawn_listener
            )],
        ],
    );

    return 1;
}

sub PCI_unregister {
    my ($self, $irc) = splice @_, 0, 2;
    $poe_kernel->post($self->{SESSION_ID} => _shutdown => delete $self->{irc});
    $poe_kernel->refcount_decrement($self->{SESSION_ID}, __PACKAGE__);
    return 1;
}

sub S_connected {
    my ($self, $irc) = splice @_, 0, 2;
    $self->{stashed} = 0;
    $self->{stash} = [ ];
    return PCI_EAT_NONE;
}

sub S_001 {
    my ($self, $irc) = splice @_, 0, 2;
    $poe_kernel->post($self->{SESSION_ID} => '_shutdown');
    $poe_kernel->post($self->{SESSION_ID} => '_spawn_listener');
    return PCI_EAT_NONE;
}

sub S_disconnected {
    my ($self, $irc) = splice @_, 0, 2;
    $poe_kernel->post($self->{SESSION_ID} => '_shutdown');
    return PCI_EAT_NONE;
}

sub S_socketerr {
    my ($self, $irc) = splice @_, 0, 2;
    $poe_kernel->post($self->{SESSION_ID} => '_shutdown');
    return PCI_EAT_NONE;
}

sub S_error {
    my ($self, $irc) = splice @_, 0, 2;
    $poe_kernel->post($self->{SESSION_ID} => '_shutdown');
    return PCI_EAT_NONE;
}

sub S_raw {
    my ($self, $irc) = splice @_, 0, 2;
    my $line  = ${ $_[0] };
    my $input = $self->{irc_filter}->get( [$line] )->[0];

    return PCI_EAT_NONE if $input->{command} eq 'PING';

    for my $wheel_id (keys %{ $self->{wheels} }) {
        $self->_send_to_client($wheel_id, $line);
    }

    return PCI_EAT_NONE if $self->{stashed};

    if ($input->{command} =~ /^(?:NOTICE|\d{3})$/) {
        push @{ $self->{stash} }, $line;
    }

    $self->{stashed} = 1 if $input->{command} =~ /^(?:376|422)$/;
    return PCI_EAT_NONE;
}

sub _send_to_client {
    my ($self, $wheel_id, $line) = splice @_, 0, 3;
    return if !defined $self->{wheels}->{ $wheel_id }->{wheel};
    return if !$self->{wheels}->{ $wheel_id }->{reg};

    $self->{wheels}->{ $wheel_id }->{wheel}->put($line);
    return;
}

sub _close_wheel {
    my ($self, $wheel_id) = splice @_, 0, 2;
    return if !defined $self->{wheels}->{ $wheel_id };

    delete $self->{wheels}->{ $wheel_id };
    $self->{irc}->send_event(irc_proxy_close => $wheel_id);
    return;
}

sub _start {
    my ($kernel, $self) = @_[KERNEL, OBJECT];

    $self->{SESSION_ID} = $_[SESSION]->ID();
    $kernel->refcount_increment($self->{SESSION_ID}, __PACKAGE__);

    $self->{irc_filter} = POE::Filter::IRCD->new();
    $self->{ircd_filter} = POE::Filter::Stackable->new(
        Filters => [
            POE::Filter::Line->new(),
            $self->{irc_filter},
        ],
    );

    if ($self->{irc}->connected()) {
        $kernel->yield('_spawn_listener');
    }
    return;
}

sub _spawn_listener {
    my $self = $_[OBJECT];

    $self->{listener} = POE::Wheel::SocketFactory->new(
        BindAddress  => $self->{bindaddress} || 'localhost',
        BindPort     => $self->{bindport} || 0,
        SuccessEvent => '_listener_accept',
        FailureEvent => '_listener_failed',
        Reuse        => 'yes',
    );

    if (!$self->{listener}) {
        my $irc = $self->{irc};
        $irc->plugin_del($self);
        return;
    }

    $self->{irc}->send_event(irc_proxy_up => $self->{listener}->getsockname());
    return;
}

sub _listener_accept {
    my ($self, $socket, $peeradr, $peerport) = @_[OBJECT, ARG0 .. ARG2];

    my $wheel = POE::Wheel::ReadWrite->new(
        Handle       => $socket,
        InputFilter  => $self->{ircd_filter},
        OutputFilter => POE::Filter::Line->new(),
        InputEvent   => '_client_input',
        ErrorEvent   => '_client_error',
        FlushedEvent => '_client_flush',
    );

    if ($wheel) {
        my $wheel_id = $wheel->ID();
        $self->{wheels}->{ $wheel_id }->{wheel} = $wheel;
        $self->{wheels}->{ $wheel_id }->{port} = $peerport;
        $self->{wheels}->{ $wheel_id }->{peer} = inet_ntoa( $peeradr );
        $self->{wheels}->{ $wheel_id }->{start} = time;
        $self->{wheels}->{ $wheel_id }->{reg} = 0;
        $self->{wheels}->{ $wheel_id }->{register} = 0;
        $self->{irc}->send_event(irc_proxy_connect => $wheel_id);
    }
    else {
        $self->{irc}->send_event(irc_proxy_rw_fail => inet_ntoa( $peeradr ) => $peerport);
    }

    return;
}

sub _listener_failed {
    delete ( $_[OBJECT]->{listener} );
    return;
}

sub _client_flush {
    my ($self, $wheel_id) = @_[OBJECT, ARG0];

    return if !defined $self->{wheels}->{ $wheel_id } || !$self->{wheels}->{ $wheel_id }->{quiting};
    $self->_close_wheel($wheel_id);
    return;
}

# this code needs refactoring
## no critic (Subroutines::ProhibitExcessComplexity)
sub _client_input {
    my ($self, $input, $wheel_id) = @_[OBJECT, ARG0, ARG1];
    my ($irc, $wheels) = ($self->{irc}, $self->{wheels});

    return if $wheels->{$wheel_id}{quiting};

    if ($input->{command} eq 'QUIT') {
        $self->_close_wheel($wheel_id);
        return;
    }

    if ($input->{command} eq 'PASS' && $wheels->{$wheel_id}{reg} < 2) {
        $wheels->{$wheel_id}{pass} = $input->{params}[0];
    }

    if ($input->{command} eq 'NICK' && $wheels->{$wheel_id}{reg} < 2) {
        $wheels->{$wheel_id}{nick} = $input->{params}[0];
        $wheels->{$wheel_id}{register}++;
    }

    if ($input->{command} eq 'USER' && $wheels->{$wheel_id}{reg} < 2) {
        $wheels->{$wheel_id}{user} = $input->{params}[0];
        $wheels->{$wheel_id}{register}++;
    }

    if (!$wheels->{$wheel_id}{reg} && $wheels->{$wheel_id}{register} >= 2) {
        my $password = delete $wheels->{$wheel_id}{pass};
        $wheels->{$wheel_id}{reg} = 1;

        if (!$password || $password ne $self->{password}) {
            $self->_send_to_client($wheel_id,
                'ERROR :Closing Link: * ['
                . ($wheels->{$wheel_id}{user} || 'unknown')
                . '@' . $wheels->{$wheel_id}{peer}
                . '] (Unauthorised connection)'
            );
            $wheels->{$wheel_id}{quiting}++;
            return;
        }

        my $nickname = $irc->nick_name();
        my $fullnick = $irc->nick_long_form($nickname);
        if ($nickname ne $wheels->{$wheel_id}{nick}) {
            $self->_send_to_client($wheel_id, "$wheels->{$wheel_id}{nick} NICK :$nickname");
        }

        for my $line (@{ $self->{stash} }) {
            $self->_send_to_client($wheel_id, $line);
        }

        for my $channel ($irc->nick_channels($nickname)) {
            $self->_send_to_client($wheel_id, ":$fullnick JOIN $channel");
            $irc->yield(names => $channel);
            $irc->yield(topic => $channel);
        }

        $irc->send_event(irc_proxy_authed => $wheel_id);
        return;
    }

    return if !$wheels->{$wheel_id}{reg};

    if ($input->{command} =~ /^(?:NICK|USER|PASS)$/) {
        return;
    }

    if ($input->{command} eq 'PING') {
        $self->_send_to_client($wheel_id, "PONG $input->{params}[0]");
        return;
    }

    if ($input->{command} eq 'PONG' and $input->{params}[0] =~ /^[0-9]+$/) {
        $wheels->{$wheel_id}{lag} = time() - $input->{params}[0];
        return;
    }

    $irc->yield(quote => $input->{raw_line});
    return;
}

sub _client_error {
    my ($self, $wheel_id) = @_[OBJECT, ARG3];

    $self->_close_wheel($wheel_id);
    return;
}

sub _shutdown {
    my $self = $_[OBJECT];
    my $irc = $self->{irc} || $_[ARG0];

    my $mysockaddr = $self->getsockname();
    delete $self->{listener};

    for my $wheel_id ( $self->list_wheels() ) {
        $self->_close_wheel( $wheel_id );
    }
    delete $self->{wheels};
    $irc->send_event(irc_proxy_down => $mysockaddr);

    return;
}

sub getsockname {
    my ($self) = @_;
    return if !$self->{listener};
    return $self->{listener}->getsockname();
}

sub list_wheels {
    my ($self) = @_;
    return keys %{ $self->{wheels} };
}

sub wheel_info {
    my ($self, $wheel_id) = @_;
    return if !defined $self->{wheels}->{ $wheel_id };
    return $self->{wheels}->{ $wheel_id }->{start} if !wantarray;
    return map { $self->{wheels}->{ $wheel_id }->{$_} } qw(peer port start lag);
}

1;

=encoding utf8

=head1 NAME

POE::Component::IRC::Plugin::Proxy - A PoCo-IRC plugin that provides a
lightweight IRC proxy/bouncer

=head1 SYNOPSIS

 use strict;
 use warnings;
 use POE qw(Component::IRC::State Component::IRC::Plugin::Proxy Component::IRC::Plugin::Connector);

 my $irc = POE::Component::IRC::State->spawn();

 POE::Session->create(
     package_states => [
         main => [ qw(_start) ],
     ],
     heap => { irc => $irc },
 );

 $poe_kernel->run();

 sub _start {
     my ($kernel, $heap) = @_[KERNEL, HEAP];
     $heap->{irc}->yield( register => 'all' );
     $heap->{proxy} = POE::Component::IRC::Plugin::Proxy->new( bindport => 6969, password => "m00m00" );
     $heap->{irc}->plugin_add( 'Connector' => POE::Component::IRC::Plugin::Connector->new() );
     $heap->{irc}->plugin_add( 'Proxy' => $heap->{proxy} );
     $heap->{irc}->yield ( connect => { Nick => 'testbot', Server => 'someserver.com' } );
     return;
 }

=head1 DESCRIPTION

POE::Component::IRC::Plugin::Proxy is a L
plugin that provides lightweight IRC proxy/bouncer server to your
L bots. It enables multiple IRC
clients to be hidden behind a single IRC client-server connection.

Spawn a L session and add in a
POE::Component::IRC::Plugin::Proxy plugin object, specifying a bindport and a
password the connecting IRC clients have to use. When the component is
connected to an IRC network a listening port is opened by the plugin for
multiple IRC clients to connect.

Neat, huh? >;o)

This plugin will activate L's raw
events (L|POE::Component::IRC/irc_raw>) by calling
C<< $irc->raw_events(1) >>.

This plugin requires the IRC component to be
L or a subclass thereof.

=head1 METHODS

=head2 C

Takes a number of arguments:

B<'password'>, the password to require from connecting clients;

B<'bindaddress'>, a local address to bind the listener to, default is 'localhost';

B<'bindport'>, what port to bind to, default is 0, ie. randomly allocated by OS;

Returns an object suitable for passing to
L's C method.

=head2 C

Takes no arguments. Accesses the listeners C method. See
L for details of the
return value;

=head2 C

Takes no arguments. Returns a list of wheel ids of the current connected clients.

=head2 C

Takes one parameter, a wheel ID to query. Returns undef if an invalid wheel id
is passed. In a scalar context returns the time that the client connected in
unix time. In a list context returns a list consisting of the peer address,
port, tthe connect time and the lag in seconds for that connection.

=head1 OUTPUT EVENTS

The plugin emits the following L
events:

=head2 C

Emitted when the listener is successfully started. C is the result of the
listener C.

=head2 C

Emitted when a client connects to the listener. C is the wheel ID of the
client.

=head2 C

Emitted when the L fails on a
connection. C is the wheel ID of the client.

=head2 C

Emitted when a connecting client successfully negotiates an IRC session with
the plugin. C is the wheel ID of the client.

=head2 C

Emitted when a connected client disconnects. C is the wheel ID of the
client.

=head2 C

Emitted when the listener is successfully shutdown. C is the result of the
listener C.

=head1 QUIRKS

Connecting IRC clients will not be able to change nickname. This is a feature.

=head1 AUTHOR

Chris 'BinGOs' Williams

=head1 SEE ALSO

L

L

=cut