File Coverage

blib/lib/Net/Graylog/Client.pm

Criterion	Covered	Total	%
statement	42	83	50.6
branch	0	16	0.0
condition	0	12	0.0
subroutine	14	19	73.6
pod	3	3	100.0
total	59	133	44.3

# ABSTRACT: Client for Graylog2 analysis server


package Net::Graylog::Client;
{
  $Net::Graylog::Client::VERSION = '0.4';
}

use strict;
use warnings;
use POSIX qw(strftime);
use Data::Printer;
use Furl;
use JSON::Tiny qw(encode_json);
use Sys::Hostname;
use Data::UUID;
use POSIX qw(strftime);
use App::Basis;

# use Mo qw( default is required );    # not using (build builder coerce)
use Moo;
use namespace::clean;

use vars qw( @EXPORT @ISA);

# -----------------------------------------------------------------------------

@ISA = qw(Exporter);

# this is the list of things that will get imported into the loading packages
# namespace
@EXPORT = qw(
    valid_levels
    valid_facilities
);

use constant GELF_VERSION => "1.1";

# -----------------------------------------------------------------------------



has url       => ( is => 'ro', required => 1 );
has _uuid     => ( is => 'ro', init_arg => undef, default => sub { Data::UUID->new() }, );
has _hostname => ( is => 'ro', init_arg => undef, default => sub { hostname(); } );
has timeout => ( is => 'ro', default => sub { 0.01; } );

# we need to set a timeout for the connection as Furl seems to wait
# for this time to elapse before giving us any response. If the default is used
# 180s then this will block for 3 minutes! crazy stuff, so I set it to 0.01
# which would allow me to send 100 messages/sec, which should be OK for my
# purposes especially as my graylog is on the local network
has _furl => (
    is      => 'lazy',
    default => sub {
        my $self = shift;
        return Furl->new(
            agent => __PACKAGE__,

            # headers => [
            #     'Accept'        => 'application/json',
            #     'content-type'  => 'application/json',
            # ],
            timeout => $self->timeout,
        );
    },
    init_arg => undef,
);

# -----------------------------------------------------------------------------

# these are the syslog severity levels
my @msg_levels  = qw( emerg alert crit error warning notice info debug);
my $_mc         = 0;
my %msg_lvalues = map { $_ => $_mc++; } @msg_levels;

# some levels have alternate names
my %msg_tx = ( panic => 'emerg', err => 'error', warn => 'warning' );

my @msg_facilities = qw(
    kern user mail daemon auth syslog lpr news
    uucp clock authpriv ftp ntp audit alert cron
    local0 local1 local2 local3 local4 local5 local6 local7
);
my $_mf = 0;
my %msg_fvalues = map { $_ => $_mf++; } @msg_facilities;

# -----------------------------------------------------------------------------


sub send {
    my $self = shift;
    my (%data) = @_;

    # we add these fields so, we will report issues if they are passed
    # for some reason graylog accepts a message with a count field
    # but then silently discards it!
    map { die "Field '$_' not allowed" if ( $data{$_} ) } qw( uuid timestamp  timestr count);

    die "message field is required" if ( !$data{message} );

    $data{version}       = GELF_VERSION;
    $data{short_message} = $data{message};
    $data{full_message}  = $data{long} || $data{full_message};
    $data{uuid}          = $self->_uuid->create_str();
    $data{timestamp}     = time();
    $data{timestr}       = strftime( "%Y-%m-%d %H:%M:%S", gmtime( time() ) );
    $data{host}          = $data{server} || $data{host} || hostname();
    $data{logger} ||= get_program();

    # convert the level to match a syslog level and stop graylog fretting
    if ( defined $data{level} && $data{level} !~ /^\d+$/ ) {

        # convert the level into a number
        my $l = $data{level};

        # get the alternate name if needed
        $l = $msg_tx{ $data{level} } if ( $msg_tx{ $data{level} } );
        if ( defined $msg_lvalues{$l} ) {
            $data{level} = $msg_lvalues{$l};

            # also save as a string for user to reference
            $data{levelstr} = $l;
        }
    }

    # remove some entries we dont want
    map { delete $data{$_} if ( exists $data{$_} ); } qw( server message long);

    # rename things that are not allowed fields
    my %allowed = map { $_ => 1 } qw(uuid timestamp host version timestr full_message short_message level facility file);
    foreach my $k ( keys %data ) {
        if ( !$allowed{$k} ) {

            # prefix with an underline and then remove original
            $data{"_$k"} = $data{$k};
            delete $data{$k};
        }
    }

    # convert any floats into strings
    # foreach my $k ( keys %data) {
    #     # floating point numbers need to be made into strings
    #     if( $data{$k} =~ /^[0-9]{1,}(\.[0-9]{1,})$/) {
    #         $data{$k} = "" . $data{$k} ;
    #     }
    # }

    my $status = $self->_furl->post( $self->url, [ 'Content-Type' => 'application/json' ], encode_json( \%data ) );

    return ( $status->is_success, $status->code );
}

# -----------------------------------------------------------------------------


sub AUTOLOAD {

    # we use AUTOLOAD to handle some aliases for send

    # find out if this is a name we alias
    my $level = our $AUTOLOAD;
    $level =~ s/.*:://;    # strip the package name
    if ( !defined $msg_lvalues{$level} ) {
        die qq(Can't locate object method $level via package "@{[__PACKAGE__]}");
    }

    my $self   = shift;
    my %params = @_;

    # set the level field
    $params{level} = $level;

    # and perform the actual send
    return $self->send(%params);
}

# -----------------------------------------------------------------------------

sub DESTROY {
    return 1;
}

# -----------------------------------------------------------------------------


sub valid_levels {
    return @msg_levels;
}

# -----------------------------------------------------------------------------


sub valid_facilities {
    return @msg_facilities;
}


# -----------------------------------------------------------------------------
1;

__END__