File Coverage

blib/lib/Log/Radis.pm

Criterion	Covered	Total	%
statement	50	54	92.5
branch	20	24	83.3
condition	4	6	66.6
subroutine	10	11	90.9
pod	2	2	100.0
total	86	97	88.6

use strictures 2;

package Log::Radis;

# ABSTRACT: Radis is a graylog logging radio through a redis database

use Moo 2;
use Redis 1.980;
use JSON 2.90 qw(encode_json);
use Time::HiRes 1.9726;
use Sys::Hostname ;
use Carp qw(croak carp);
use Scalar::Util qw(blessed);

our $GELF_SPEC_VERSION = '1.1';
our $HOSTNAME = hostname();

our $VERSION = '0.003'; # VERSION



has server => (
    is => 'ro',
    default => 'localhost:6379',
);


has reconnect => (
    is => 'ro',
    default => 5,
);


has every => (
    is => 'ro',
    default => 1,
);


has queue => (
    is => 'ro',
    default => 'graylog-radis:queue',
);


has redis => (
    is => 'lazy',
    isa => sub {
        (blessed($_[0]) and ($_[0]->isa('Redis') or $_[0]->can('lpush'))) or
        croak "Must be an instance of Redis".
            " or a blessed reference implementing the 'lpush' method";
    },
    builder => sub {
        my $self = shift;
        return Redis->new(
            server    => $self->server,
            reconnect => $self->reconnect,
            every     => $self->every,
        );
    }
);


my %levels = (
    fatal     => 1,
    emerg     => 1,
    emergency => 1,

    alert     => 2,

    crit      => 2,
    critical  => 3,

    error     => 4,
    err       => 4,

    warn      => 5,
    warning   => 5,

    note      => 6,
    notice    => 6,

    info      => 7,

    debug     => 8,

    trace     => 9,
    core      => 9,
);


sub log {
    my $self = shift;
    my ($level, $message, %gelf) = @_;

    croak "log message without level" unless defined $level;
    croak "log message without message" unless defined $message;

    # replace level with numeric code, if needed
    $level = $levels{lc($level)} unless $level =~ m{^\d$};

    # addiotional field are only allowed with a prefixed underscore
    # and strip off all unallowed chars
    %gelf = map {
        m{^_[\w\.\-]+$}i
    ?
        (
            lc($_)
        ,
            $gelf{$_}
        )
    :
        (
            '_'.s{[^\w\.\-]+}{}gr
        ,
            $gelf{$_}
        )
    } grep { defined $gelf{$_} } keys %gelf;

    # graylog omit the id field automatically
    if (exists $gelf{_id}) {
        carp "log message with id is not allowed";
        delete $gelf{_id};
    }

    # preserve params, which are allowed by client
    # including some mispelled ones
    $gelf{host}         = delete $gelf{_hostname}       if defined $gelf{_hostname};
    $gelf{host}         = delete $gelf{_host}           if defined $gelf{_host};
    $gelf{timestamp}    = delete $gelf{_time}           if defined $gelf{_time};
    $gelf{timestamp}    = delete $gelf{_timestamp}      if defined $gelf{_timestamp};
    $gelf{full_message} = delete $gelf{_message}        if defined $gelf{_message};
    $gelf{full_message} = delete $gelf{_full_message}   if defined $gelf{_full_message};

    # hostname defaults to system hostname...
    $gelf{host} //= $HOSTNAME;

    # ...and timestamp with milliseconds by default
    $gelf{timestamp} //= Time::HiRes::time();

    # graylog seems to have problems with float values in json
    # so force string, which works fine
    $gelf{timestamp} = ''.$gelf{timestamp};

    $gelf{short_message} = $message;
    $gelf{version} = $GELF_SPEC_VERSION;
    $gelf{level} = $level;

    $self->push(\%gelf);
}


sub push {
    my ($self, $gelf) = @_;
    if (ref $gelf eq 'HASH') {
        $gelf = encode_json($gelf);
    }
    $self->redis->lpush($self->queue, $gelf);
}

1;

__END__