File Coverage

blib/lib/POE/Component/Client/NSCA.pm

Criterion	Covered	Total	%
statement	305	361	84.4
branch	28	66	42.4
condition	5	22	22.7
subroutine	74	77	96.1
pod	1	1	100.0
total	413	527	78.3

package POE::Component::Client::NSCA;

use strict;
use warnings;
use POE qw(Wheel::SocketFactory Filter::Stream Wheel::ReadWrite);
use Carp;
use Socket;
use integer;
use vars qw($VERSION);

$VERSION = '0.16';

use constant PROGRAM_VERSION => "1.2.0b4-Perl";
use constant MODIFICATION_DATE => "16-03-2006";

use constant OK	=> 0;
use constant ERROR => -1;

use constant TRUE => 1;
use constant FALSE => 0;

use constant STATE_CRITICAL => 	2	; # /* service state return codes */
use constant STATE_WARNING => 	1	;
use constant STATE_OK =>       	0	;
use constant STATE_UNKNOWN =>	3	; # Updated for Nagios.

use constant DEFAULT_SOCKET_TIMEOUT	=> 10	; # /* timeout after 10 seconds */
use constant DEFAULT_SERVER_PORT =>	5667	; # /* default port to use */

use constant MAX_INPUT_BUFFER =>	2048	; # /* max size of most buffers we use */
use constant MAX_HOST_ADDRESS_LENGTH =>	256	; # /* max size of a host address */
use constant MAX_HOSTNAME_LENGTH =>	64	;
use constant MAX_DESCRIPTION_LENGTH =>	128;
use constant MAX_PLUGINOUTPUT_LENGTH =>	512;
use constant MAX_PASSWORD_LENGTH =>     512;

use constant ENCRYPT_NONE =>            0       ; # /* no encryption */
use constant ENCRYPT_XOR =>             1       ; # /* not really encrypted, just obfuscated */
use constant ENCRYPT_DES =>             2       ; # /* DES */
use constant ENCRYPT_3DES =>            3       ; # /* 3DES or Triple DES */
use constant ENCRYPT_CAST128 =>         4       ; # /* CAST-128 */
use constant ENCRYPT_CAST256 =>         5       ; # /* CAST-256 */
use constant ENCRYPT_XTEA =>            6       ; # /* xTEA */
use constant ENCRYPT_3WAY =>            7       ; # /* 3-WAY */
use constant ENCRYPT_BLOWFISH =>        8       ; # /* SKIPJACK */
use constant ENCRYPT_TWOFISH =>         9       ; # /* TWOFISH */
use constant ENCRYPT_LOKI97 =>          10      ; # /* LOKI97 */
use constant ENCRYPT_RC2 =>             11      ; # /* RC2 */
use constant ENCRYPT_ARCFOUR =>         12      ; # /* RC4 */
use constant ENCRYPT_RC6 =>             13      ; # /* RC6 */            ; # /* UNUSED */
use constant ENCRYPT_RIJNDAEL128 =>     14      ; # /* RIJNDAEL-128 */
use constant ENCRYPT_RIJNDAEL192 =>     15      ; # /* RIJNDAEL-192 */
use constant ENCRYPT_RIJNDAEL256 =>     16      ; # /* RIJNDAEL-256 */
use constant ENCRYPT_MARS =>            17      ; # /* MARS */           ; # /* UNUSED */
use constant ENCRYPT_PANAMA =>          18      ; # /* PANAMA */         ; # /* UNUSED */
use constant ENCRYPT_WAKE =>            19      ; # /* WAKE */
use constant ENCRYPT_SERPENT =>         20      ; # /* SERPENT */
use constant ENCRYPT_IDEA =>            21      ; # /* IDEA */           ; # /* UNUSED */
use constant ENCRYPT_ENIGMA =>          22      ; # /* ENIGMA (Unix crypt) */
use constant ENCRYPT_GOST =>            23      ; # /* GOST */
use constant ENCRYPT_SAFER64 =>         24      ; # /* SAFER-sk64 */
use constant ENCRYPT_SAFER128 =>        25      ; # /* SAFER-sk128 */
use constant ENCRYPT_SAFERPLUS =>       26      ; # /* SAFER+ */

use constant TRANSMITTED_IV_SIZE =>     128     ; # /* size of IV to transmit - must be as big as largest IV needed for any crypto algorithm */


use constant NSCA_PACKET_VERSION_3 =>	3		; # /* packet version identifier */
use constant NSCA_PACKET_VERSION_2 =>	2		; # /* packet version identifier */
use constant NSCA_PACKET_VERSION_1 =>	1		; # /* older packet version identifier */

use constant SIZEOF_U_INT32_T   => 4;
use constant SIZEOF_INT16_T     => 2;
use constant SIZEOF_INIT_PACKET => TRANSMITTED_IV_SIZE + SIZEOF_U_INT32_T;

use constant PROBABLY_ALIGNMENT_ISSUE => 4;

use constant SIZEOF_DATA_PACKET => SIZEOF_INT16_T + SIZEOF_U_INT32_T + SIZEOF_U_INT32_T + SIZEOF_INT16_T + MAX_HOSTNAME_LENGTH + MAX_DESCRIPTION_LENGTH + MAX_PLUGINOUTPUT_LENGTH + PROBABLY_ALIGNMENT_ISSUE;

# Work out whether we have the mcrypt libraries on board.
my $HAVE_MCRYPT = 0;
eval {
	require Mcrypt;
	$HAVE_MCRYPT++;
};

# Lookups for loading.
my %mcrypts =   (       ENCRYPT_DES,            "des",
                        ENCRYPT_3DES,           "3des",
                        ENCRYPT_CAST128,        "cast-128",
                        ENCRYPT_CAST256,        "cast-256",
                        ENCRYPT_XTEA,           "xtea",
                        ENCRYPT_3WAY,           "threeway",
                        ENCRYPT_BLOWFISH,       "blowfish",
                        ENCRYPT_TWOFISH,        "twofish",
                        ENCRYPT_LOKI97,         "loki97",
                        ENCRYPT_RC2,            "rc2",
                        ENCRYPT_ARCFOUR,        "arcfour",
                        ENCRYPT_RC6,            "rc6",
                        ENCRYPT_RIJNDAEL128,    "rijndael-128",
                        ENCRYPT_RIJNDAEL192,    "rijndael-192",
                        ENCRYPT_RIJNDAEL256,    "rijndael-256",
                        ENCRYPT_MARS,           "mars",
                        ENCRYPT_PANAMA,         "panama",
                        ENCRYPT_WAKE,           "wake",
                        ENCRYPT_SERPENT,        "serpent",
                        ENCRYPT_IDEA,           "idea",
                        ENCRYPT_ENIGMA,         "engima",
                        ENCRYPT_GOST,           "gost",
                        ENCRYPT_SAFER64,        "safer-sk64",
                        ENCRYPT_SAFER128,       "safer-sk128",
                        ENCRYPT_SAFERPLUS,      "saferplus",
                );

sub send_nsca {
  my $package = shift;
  my %params = @_;
  $params{lc $_} = delete $params{$_} for keys %params;
  croak "$package requires a 'host' argument\n"
	unless $params{host};
  croak "$package requires an 'event' argument\n"
	unless $params{event};
  croak "$package requires a 'password' argument\n"
	unless $params{password} || $params{encryption} eq ENCRYPT_XOR;
  croak "$package requires an 'encryption' argument\n"
	unless defined $params{encryption};
  croak "$package requires a 'message' argument and it must be a hashref\n"
	unless $params{message} and ref $params{message} eq 'HASH';
  foreach my $item ( qw(host_name return_code plugin_output) ) {
     croak "'message' hashref must have a '$item' key\n"
	unless defined $params{message}->{$item};
  }
  _correct_message( $params{message} );
  $params{port} = 5667 unless defined $params{port};
  $params{timeout} = 10 unless defined $params{timeout} and $params{timeout} =~ /^\d+$/;
  my $options = delete $params{options};
  my $self = bless \%params, $package;
  $self->{session_id} = POE::Session->create(
	object_states => [
	   $self => [ qw(_start _connect _sock_up _sock_err _sock_in _sock_flush _sock_down _send_response _timeout) ],
	],
	heap => $self,
	( ref($options) eq 'HASH' ? ( options => $options ) : () ),
  )->ID();
  return $self;
}

sub _start {
  my ($kernel,$sender,$self) = @_[KERNEL,SENDER,OBJECT];
  $self->{session_id} = $_[SESSION]->ID();
  $self->{filter} = POE::Filter::Stream->new();
  if ( $kernel == $sender and !$self->{session} ) {
	croak "Not called from another POE session and 'session' wasn't set\n";
  }
  my $sender_id;
  if ( $self->{session} ) {
    if ( my $ref = $kernel->alias_resolve( $self->{session} ) ) {
	$sender_id = $ref->ID();
    }
    else {
	croak "Could not resolve 'session' to a valid POE session\n";
    }
  }
  else {
    $sender_id = $sender->ID();
  }
  $kernel->refcount_increment( $sender_id, __PACKAGE__ );
  $self->{sender_id} = $sender_id;
  $kernel->yield( '_connect' );
  return;
}

sub _connect {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $self->{sockfactory} = POE::Wheel::SocketFactory->new(
	SocketProtocol => 'tcp',
	RemoteAddress => $self->{host},
	RemotePort => $self->{port},
	SuccessEvent => '_sock_up',
	FailureEvent => '_sock_err',
  );
  $kernel->delay( '_timeout', $self->{timeout} );
  return;
}

sub _timeout {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  delete $self->{sockfactory};
  delete $self->{socket};
  $kernel->yield( '_send_response', 'timeout' );
  return;
}

sub _sock_err {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $kernel->delay( '_timeout' );
  delete $self->{sockfactory};
  $kernel->yield( '_send_response', 'sockerr', @_[ARG0..ARG2] );
  return;
}

sub _sock_up {
  my ($kernel,$self,$socket) = @_[KERNEL,OBJECT,ARG0];
  $kernel->delay( '_timeout' );
  delete $self->{sockfactory};
  $self->{socket} = new POE::Wheel::ReadWrite
    ( Handle     => $socket,
      Filter     => $self->{filter},
      InputEvent => '_sock_in',
      ErrorEvent => '_sock_down',
      FlushedEvent => '_sock_flush',
  );
  $self->{state} = 'init';
  $kernel->delay( '_timeout', $self->{timeout} );
  return;
}

sub _sock_down {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  delete $self->{socket};
  $kernel->delay( '_timeout' );
  return;
}

sub _sock_in {
  my ($kernel,$self,$input) = @_[KERNEL,OBJECT,ARG0];
  unless ( length( $input ) == SIZEOF_INIT_PACKET ) {
	$kernel->yield( '_send_response', 'badinit', length( $input ) );
	delete $self->{socket};
	return;
  }
  my $init_packet = {
      iv => substr($input, 0, TRANSMITTED_IV_SIZE),
      timestamp => substr($input, TRANSMITTED_IV_SIZE, SIZEOF_U_INT32_T),
  };
  my $data_packet_string_a = pack('n', NSCA_PACKET_VERSION_3) . "\000\000";
  my $data_packet_string_b =
	$init_packet->{timestamp} .
	pack('n', $self->{message}->{return_code}) .
	pack(('a'.MAX_HOSTNAME_LENGTH), $self->{message}->{host_name}) .
	pack(('a'.MAX_DESCRIPTION_LENGTH), $self->{message}->{svc_description} || '') .
	pack(('a'.MAX_PLUGINOUTPUT_LENGTH), $self->{message}->{plugin_output}) .
	"\000\000";
  my $crc = _calculate_crc32( $data_packet_string_a . pack( 'N', 0 ) . $data_packet_string_b);
  my $data_packet_string = $data_packet_string_a . pack('N', $crc) . $data_packet_string_b;
  my $data_packet_string_crypt = _encrypt($data_packet_string, $self->{encryption}, $init_packet->{iv}, $self->{password} );
  unless ( $data_packet_string_crypt ) {
	$kernel->yield( '_send_response', 'badencrypt' );
	delete $self->{socket};
	return;
  }
  $self->{socket}->put( $data_packet_string_crypt );
  return;
}

sub _sock_flush {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $kernel->delay( '_timeout' );
  delete $self->{socket};
  $kernel->yield( '_send_response', 'success' );
  return;
}

sub _send_response {
  my ($kernel,$self,$type) = @_[KERNEL,OBJECT,ARG0];
  my $response = { };
  $response->{$_} = $self->{$_} for qw(host message context);
  SWITCH: {
     if ( $type eq 'badinit' ) {
	$response->{error} = 'Error: bad initialisation string from peer expected' . SIZEOF_INIT_PACKET . ' got ' . $_[ARG1];
	last SWITCH;
     }
     if ( $type eq 'badencrypt' ) {
	$response->{error} = 'Error: There was a problem with the encryption';
	last SWITCH;
     }
     if ( $type eq 'sockerr' ) {
	$response->{error} = 'Error: socket error: ' . join(' ', @_[ARG1..$#_]);
	last SWITCH;
     }
     if ( $type eq 'timeout' ) {
	$response->{error} = sprintf("Error: Socket timeout after %d seconds.", $self->{timeout} );
	last SWITCH;
     }
     $response->{success} = 1;
  }
  $kernel->post( $self->{sender_id}, $self->{event}, $response );
  $kernel->refcount_decrement( $self->{sender_id}, __PACKAGE__ );
  $kernel->alarm_remove_all();
  return;
}

# truncates long fields
sub _correct_message {
  my $message = shift;

  $message->{'svc_description'} = '' unless defined $message->{'svc_description'};
  if (length( $message->{'host_name'} ) >= MAX_HOSTNAME_LENGTH) {
     warn("Hostname too long - truncated");
     $message->{'host_name'} = substr($message->{'host_name'}, 0, MAX_HOSTNAME_LENGTH-1);
  }
  if (length( $message->{'svc_description'} ) >= MAX_DESCRIPTION_LENGTH) {
     warn("Description too long - truncated");
     $message->{'svc_description'} = substr($message->{'svc_description'}, 0, MAX_DESCRIPTION_LENGTH-1);
  }
  if (length( $message->{'plugin_output'} ) >= MAX_PLUGINOUTPUT_LENGTH) {
     warn("Plugin Output too long - truncated");
     $message->{'plugin_output'} = substr($message->{'plugin_output'}, 0, MAX_PLUGINOUTPUT_LENGTH-1);
  }
  return $message;
}


#/* calculates the CRC 32 value for a buffer */
sub _calculate_crc32 {
        my $string = shift;

        my $crc32_table = _generate_crc32_table();
        my $crc = 0xFFFFFFFF;

        foreach my $tchar (split(//, $string)) {
                my $char = ord($tchar);
                $crc = (($crc >> 8) & 0x00FFFFFF) ^ $crc32_table->[($crc ^ $char) & 0xFF];
        }

        return ($crc ^ 0xFFFFFFFF);
}

#/* build the crc table - must be called before calculating the crc value */
sub _generate_crc32_table {
        my $crc32_table = [];
        my $poly = 0xEDB88320;

        for (my $i = 0; $i < 256; $i++){
                my $crc = $i;
                for (my $j = 8; $j > 0; $j--) {
                        if ($crc & 1) {
                                $crc = ($crc >> 1) ^ $poly;
                        } else {
                                $crc = ($crc >> 1);
                        }
                }
                $crc32_table->[$i] = $crc;
        }
        return $crc32_table;
}

# central switchboard for encryption methods.
sub _encrypt {
        my ($data_packet_string, $encryption_method, $iv_salt, $password) = @_;

        my $crypted;
        if ($encryption_method == ENCRYPT_NONE) {
                $crypted = $data_packet_string;
        } elsif ($encryption_method == ENCRYPT_XOR) {
                $crypted = _encrypt_xor($data_packet_string, $iv_salt, $password);
        } else {
                $crypted = _encrypt_mcrypt( $data_packet_string, $encryption_method, $iv_salt, $password );
        }
        return $crypted;
}

sub _encrypt_xor {
        my ($data_packet_string, $iv_salt, $password) = @_;

        my @out = split(//, $data_packet_string);
        my @salt_iv = split(//, $iv_salt);
        my @salt_pw = split(//, $password);

        my $y = 0;
        my $x = 0;

        #/* rotate over IV we received from the server... */
        while ($y < SIZEOF_DATA_PACKET) {
                #/* keep rotating over IV */
                $out[$y] = $out[$y] ^ $salt_iv[$x % scalar(@salt_iv)];

                $y++;
                $x++;
        }

        if ($password) {
            #/* rotate over password... */
            $y=0;
            $x=0;
            while ($y < SIZEOF_DATA_PACKET){
                    #/* keep rotating over password */
                    $out[$y] = $out[$y] ^ $salt_pw[$x % scalar(@salt_pw)];

                    $y++;
                    $x++;
            }
        }
        return( join('',@out) );
}

sub _encrypt_mcrypt {
  my ( $data_packet_string, $encryption_method, $iv_salt, $password ) = @_;
  my $crypted;
  my $evalok = 0;
  if( $HAVE_MCRYPT ){
     # Initialise the routine
     if( defined( $mcrypts{$encryption_method} ) ){
        # Load the routine.
        my $routine = $mcrypts{$encryption_method};
        eval {
           # This sometimes dies with 'mcrypt is not of type MCRYPT'.
           my $td = Mcrypt->new( algorithm => $routine, mode => 'cfb', verbose => 0 );
           my $key = $password;
           my $iv = substr $iv_salt, 0, $td->{IV_SIZE};
           if( defined( $td ) ){
               $td->init($key, $iv);
	       for (my $i = 0; $i < length( $data_packet_string ); $i++ ) {
		 $crypted .= $td->encrypt( substr $data_packet_string, 0+$i, 1 );
	       }
               $td->end();
           }
           $evalok++;
        };
	warn "$@\n" if $@;
     }
  }

  # Mcrypt is fastest, but for some routines, there are alternatives if
  # your perl Mcrypt <-> libmcrypt linkage isn't working.
  if( ! $evalok && ! defined( $crypted ) && defined( $encryption_method )){
      if( defined( $mcrypts{$encryption_method} ) && 1 == 2 ){
         my $routine = '_encrypt_' . $mcrypts{$encryption_method};
         if( $routine !~ /_$/ ){
            eval {
              $crypted = $routine->( $data_packet_string, $encryption_method, $iv_salt, $password );
            };
         }
      }
   }
   return( $crypted );
}


'Yn anfon i maes an SOS';

__END__