File Coverage

blib/lib/App/Manoc/Netwalker/Control.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package App::Manoc::Netwalker::Control;
#ABSTRACT: Netwalker control interface


use Moose;

our $VERSION = '2.99.2'; ##TRIAL VERSION

use namespace::autoclean;

with 'App::Manoc::Logger::Role';

use IO::Socket;
use POE qw(Wheel::ListenAccept Wheel::ReadWrite);


has config => (
    is       => 'ro',
    isa      => 'App::Manoc::Netwalker::Config',
    required => 1
);


has poller => (
    is       => 'ro',
    isa      => 'App::Manoc::Netwalker::Poller::Workers',
    required => 1,
);


has discoverer => (
    is       => 'ro',
    isa      => 'App::Manoc::Netwalker::Discover::Workers',
    required => 1,
);


has server => (
    is  => 'rw',
    isa => 'Ref',
);


has session => (
    isa       => 'POE::Session',
    is        => 'ro',
    required  => 1,
    lazy      => 1,
    builder   => '_build_session',
    clearer   => 'remove_server',
    predicate => 'has_server',
);


has clients => (
    traits   => ['Hash'],
    isa      => 'HashRef',
    is       => 'rw',
    lazy     => 1,
    required => 1,
    default  => sub { {} },
    handles  => {
        set_client     => 'set',
        get_client     => 'get',
        remove_client  => 'delete',
        has_client     => 'count',
        num_client     => 'count',
        get_client_ids => 'keys',
    },
);


sub MANOC_CONSOLE_HELLO { "OK Manoc Netwalker console" }

sub _build_session {
    my $self = shift;

    return POE::Session->create(
        object_states => [
            $self => [
                qw(
                    _start
                    on_client_accept
                    on_server_error
                    on_client_input
                    on_client_error
                    )
            ],
        ],
    );
}

sub _start {
    my ( $self, $job, $args, $kernel, $heap ) = @_[ OBJECT, ARG0, ARG1, KERNEL, HEAP ];

    my $port = $self->config->control_port;

    my $handle;
    if ( $port =~ m|^/| ) {
        # looks like a path, create a UNIX socket
        $handle = IO::Socket::UNIX->new(
            Type   => SOCK_STREAM(),
            Local  => $port,
            Listen => 1,
        );
    }
    else {
        # TCP socket
        $handle = IO::Socket::INET->new(
            LocalPort => $port,
            Listen    => 5,
            ReuseAddr => 1,
        );
    }
    $handle or $self->log->logdie("Cannot create control socket $port: $!");

    # Start the server.
    my $server = POE::Wheel::ListenAccept->new(
        Handle      => $handle,
        AcceptEvent => "on_client_accept",
        ErrorEvent  => "on_server_error",
    );
    $self->server($server);
}


sub on_client_accept {
    my ( $self, $client_socket ) = @_[ OBJECT, ARG0 ];
    my $io_wheel = POE::Wheel::ReadWrite->new(
        Handle     => $client_socket,
        InputEvent => "on_client_input",
        ErrorEvent => "on_client_error",
    );

    $io_wheel->put(MANOC_CONSOLE_HELLO);

    $self->set_client( $io_wheel->ID => $io_wheel );
}


sub on_server_error {
    my ( $self, $operation, $errnum, $errstr ) = @_[ OBJECT, ARG0, ARG1, ARG2 ];
    warn "Server $operation error $errnum: $errstr\n";
    $self->server(undef);
}


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

    my $client = $self->get_client($wheel_id);

    my @tokens = split( /\s+/, $input );
    my $command = lc( shift @tokens );

    my $handler = "command_$command";
    if ( $self->can($handler) ) {
        my $output = $self->$handler(@tokens);
        $client->put($output);
    }
    elsif ( $command eq 'close' ) {
        $self->remove_client($wheel_id);
    }
    else {
        $client->put("ERR Unknown command $command");
    }
}


sub on_client_error {
    my $self     = $_[OBJECT];
    my $wheel_id = $_[ARG3];

    # Handle client error, including disconnect.
    $self->remove_client($wheel_id);
}


sub command_status {
    my $self = shift;

    my $scoreboard = $self->poller->scoreboard_status;
    my $output     = "OK " . scalar( keys(%$scoreboard) ) . " elements";

    while ( my ( $k, $v ) = each(%$scoreboard) ) {
        $output .= "\n$k $v";
    }

    return $output;
}


sub command_enqueue {
    my ( $self, $type, $id ) = @_;

    $type = lc($type);
    if ( $type eq 'device' ) {
        $self->poller->enqueue_device($id);
        return "OK added device $id";
    }
    if ( $type eq 'server' ) {
        $self->poller->enqueue_server($id);
        return "OK added server $id";
    }

    return "ERR unknown object $type";
}


sub command_quit {
    my $self     = $_[OBJECT];
    my $wheel_id = $_[ARG3];

    # Handle client error, including disconnect.
    $self->remove_client($wheel_id);
}

sub BUILD {
    shift->session();
}

no Moose;
__PACKAGE__->meta->make_immutable;

# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 4
# cperl-indent-parens-as-block: t
# End:

__END__

=pod

=head1 NAME

App::Manoc::Netwalker::Control - Netwalker control interface

=head1 VERSION

version 2.99.2

=head1 DESCRIPTION

This class implements a control server for Netwalker. It is based on a simple line oriented protocol.

=head1 ATTRIBUTES

=head2 config

Netwalker configuration. Required.

The value in config->control_port can be a port (TCP socket) or a path (UNIX socket)

=head2 poller

Reference to poller Workers object. Required.

=head2 poller

Reference to discovery workers object. Required.

=head2 server

A L<POE::Wheel::ListenAccept> creating during _start.

=head2 session

POE session. Required.

=head2 clients

Hash wheel-id to wheel, used by callbacks.

=head1 METHODS

=head2 on_client_accept

Callback on new client connection.

=head2 on_server_error( $operation, $errnum, $errstr )

Callback on server error

=head2 on_client_input( $input, $wheel_id )

Callback for client input. Parses input line and call the corresponding command_<name> callback.

=head2 on_client_error

=head2 command_status

Manages the C<STATUS> command.

=head2 command_enqueue

Manages the C<ENQUEUE DEVICE|SERVER <id>> command.

=head2 command_quit

Manages the C<QUIT> command closing the client connection.

=head1 FUNCTIONS

=head2 MANOC_CONSOLE_HELLO

Return the welcome message

=head1 AUTHORS

=over 4

=item *

Gabriele Mambrini <[e-mail]>

=item *

Enrico Liguori

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017 by Gabriele Mambrini.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut