File Coverage

blib/lib/Log/GELF/Util.pm

Criterion	Covered	Total	%
statement	142	148	95.9
branch	40	48	83.3
condition	10	21	47.6
subroutine	30	30	100.0
pod	11	11	100.0
total	233	258	90.3

package Log::GELF::Util;
use 5.010;
use strict;
use warnings;

require Exporter;
use Readonly;

our (
    $VERSION,
    @ISA,
    @EXPORT_OK,
    %EXPORT_TAGS,
    $GELF_MSG_MAGIC,
    $ZLIB_MAGIC,
    $GZIP_MAGIC,
    %LEVEL_NAME_TO_NUMBER,
    %LEVEL_NUMBER_TO_NAME,
    %GELF_MESSAGE_FIELDS,
    $LEVEL_NAME_REGEX,
);

$VERSION = "0.96";

use Params::Validate qw(
    validate
    validate_pos
    validate_with
    SCALAR
    ARRAYREF
    HASHREF
);
use Time::HiRes qw(time);
use Sys::Syslog qw(:macros);
use Sys::Hostname;
use JSON::MaybeXS qw(encode_json decode_json);
use IO::Compress::Gzip qw(gzip $GzipError);
use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
use IO::Compress::Deflate qw(deflate $DeflateError);
use IO::Uncompress::Inflate qw(inflate $InflateError);
use Math::Random::MT qw(irand);

Readonly $GELF_MSG_MAGIC => pack('C*', 0x1e, 0x0f);
Readonly $ZLIB_MAGIC     => pack('C*', 0x78, 0x9c);
Readonly $GZIP_MAGIC     => pack('C*', 0x1f, 0x8b);

Readonly %LEVEL_NAME_TO_NUMBER => (
    emerg  => LOG_EMERG,
    alert  => LOG_ALERT,
    crit   => LOG_CRIT,
    err    => LOG_ERR,
    warn   => LOG_WARNING,
    notice => LOG_NOTICE,
    info   => LOG_INFO,
    debug  => LOG_DEBUG,
);

Readonly %LEVEL_NUMBER_TO_NAME => (
    &LOG_EMERG   =>  'emerg',
    &LOG_ALERT   =>  'alert',
    &LOG_CRIT    =>  'crit',
    &LOG_ERR     =>  'err',
    &LOG_WARNING =>  'warn',
    &LOG_NOTICE  =>  'notice',
    &LOG_INFO    =>  'info',
    &LOG_DEBUG   =>  'debug',
);

Readonly %GELF_MESSAGE_FIELDS => (
    version        => 1,
    host           => 1,
    short_message  => 1,
    full_message   => 1,
    timestamp      => 1,
    level          => 1,
    facility       => 0,
    line           => 0,
    file           => 0,
);

my $ln = '^(' .
    (join '|', (keys %LEVEL_NAME_TO_NUMBER)) .
    ')\w*$';
$LEVEL_NAME_REGEX = qr/$ln/i;
undef $ln;

@ISA       = qw(Exporter);
@EXPORT_OK = qw(
    $GELF_MSG_MAGIC
    $ZLIB_MAGIC
    $GZIP_MAGIC
    %LEVEL_NAME_TO_NUMBER
    %LEVEL_NUMBER_TO_NAME
    %GELF_MESSAGE_FIELDS
    validate_message
    encode
    decode
    compress
    uncompress
    enchunk
    dechunk
    is_chunked
    decode_chunk
    parse_level
    parse_size
);

push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');

sub validate_message {
    my %p = validate_with(
        params      => \@_,
        allow_extra => 1,
        spec        => {
            version       => {
                default => '1.1',
                callbacks => {
                    version_check => sub {
                        my $version = shift;
                        $version =~ /^1\.1$/
                            or die 'version must be 1.1, supplied $version';
                    },
                },
            },
            host          => { type => SCALAR, default => hostname() },
            short_message => { type => SCALAR },
            full_message  => { type => SCALAR, optional => 1 },
            timestamp     => {
                type => SCALAR,
                default   => time(),
                callbacks => {
                    ts_format => sub {
                        my $ts = shift;
                        $ts =~ /^\d+(?:\.\d+)*$/
                            or die 'bad timestamp';
                    },
                },
            },
            level         => { type => SCALAR, default  => 1 },
            facility      => {
                type      => SCALAR,
                optional  => 1,
            },
            line          => {
                type      => SCALAR,
                optional  => 1,
                callbacks => {
                    facility_check => sub {
                        my $line = shift;
                        $line =~ /^\d+$/
                            or die 'line must be a number';
                    },
                },
            },
            file          => {
                type      => SCALAR,
                optional  => 1,
            },
        },
    );

    $p{level} = parse_level($p{level});

    foreach my $key ( keys %p ) {

        if ( ! $key =~ /^[\w\.\-]+$/ ) {
            die "invalid field name '$key'";
        }

        if ( $key eq '_id' ||
             ! ( exists $GELF_MESSAGE_FIELDS{$key} || $key =~ /^_/ )
        ) {
            die "invalid field '$key'";
        }

        if ( exists $GELF_MESSAGE_FIELDS{$key}
             && $GELF_MESSAGE_FIELDS{$key} == 0 ) {
            # field is deprecated
            warn "$key is deprecated, send as additional field instead";
        }
    }

    return \%p;
}

sub encode {
    my @p = validate_pos(
        @_,
        { type => HASHREF },
    );

    return encode_json(validate_message(@p));
}

sub decode {
    my @p = validate_pos(
        @_,
        { type => SCALAR },
    );

    my $msg = shift @p;

    return validate_message(decode_json($msg));
}

sub compress {
    my @p = validate_pos(
        @_,
        { type  => SCALAR },
        {
            type    => SCALAR,
            default => 'gzip',
            callbacks => {
                compress_type => sub {
                    my $level = shift;
                    $level =~ /^(?:zlib|gzip)$/
                        or die 'compression type must be gzip (default) or zlib';
                },
            },
        },
    );

    my ($message, $type) = @p;

    my $method = \&gzip;
    my $error  = \$GzipError;
    if ( $type eq 'zlib' ) {
        $method = \&deflate;
        $error  = \$DeflateError;
    }

    my $msgz;
    &{$method}(\$message => \$msgz)
      or die "compress failed: ${$error}";

    return $msgz;
}

sub uncompress {
    my @p = validate_pos(
        @_,
        { type => SCALAR }
    );

    my $message = shift @p;

    my $msg_magic = substr $message, 0, 2;

    my $method;
    my $error;
    if ($ZLIB_MAGIC eq $msg_magic) {
        $method = \&inflate;
        $error  = \$InflateError;
    }
    elsif ($GZIP_MAGIC eq $msg_magic) {
        $method = \&gunzip;
        $error  = \$GunzipError;
    }
    else {
        #assume plain message
        return $message;
    }

    my $msg;
    &{$method}(\$message => \$msg)
      or die "uncompress failed: ${$error}";

    return $msg;
}

sub enchunk {
    my @p = validate_pos(
        @_,
        { type => SCALAR },
        { type => SCALAR, default => 'wan' },
        { type => SCALAR, default => pack('L*', irand(),irand()) },
    );

    my ($message, $size, $message_id) = @p;

    if ( length $message_id != 8 ) {
        die "message id must be 8 bytes";
    }

    $size = parse_size($size);

    if ( $size > 0
         && length $message > $size
    ) {
        my @chunks;
        while (length $message) {
            push @chunks, substr $message, 0, $size, '';
        }

        my $n_chunks = scalar @chunks;
        die 'Message too big' if $n_chunks > 128;

        my $sequence_count = pack('C*', $n_chunks);

        my @chunks_w_header;
        my $sequence_number = 0;
        foreach my $chunk (@chunks) {
           push @chunks_w_header,
              $GELF_MSG_MAGIC
              . $message_id
              . pack('C*',$sequence_number++)
              . $sequence_count
              . $chunk;
        }

        return @chunks_w_header;
    }
    else {
         return ($message);
    }
}

sub dechunk {
    my @p = validate_pos(
        @_,
        { type => ARRAYREF },
        { type => HASHREF },
    );

    my ($accumulator, $chunk) = @_;

    if ( ! exists $chunk->{id}
           && exists $chunk->{sequence_number}
           && exists $chunk->{sequence_count}
           && exists $chunk->{data}
    ) {
        die 'malformed chunk';
    }

    if ($chunk->{sequence_number} > $chunk->{sequence_count} ) {
        die 'chunk sequence number > count';
    }

    $accumulator->[$chunk->{sequence_number}] = $chunk->{data};

    if ( (scalar grep {defined} @{$accumulator}) == $chunk->{sequence_count} ) {
        return join '', @{$accumulator};
    }
    else {
        return;
    }
}

sub is_chunked {
    my @p = validate_pos(
        @_,
        { type => SCALAR },
    );

    my $chunk = shift @p;

    return $GELF_MSG_MAGIC eq substr $chunk, 0, 2;
}

sub decode_chunk {
    my @p = validate_pos(
        @_,
        { type => SCALAR },
    );

    my $encoded_chunk = shift;

    if ( is_chunked($encoded_chunk) ) {

        my $id      = substr $encoded_chunk,  2, 8;
        my $seq_no  = unpack('C',  substr $encoded_chunk, 10, 1);
        my $seq_cnt = unpack('C',  substr $encoded_chunk, 11, 1);
        my $data    = substr $encoded_chunk, 12;

        return {
            id              => $id,
            sequence_number => $seq_no,
            sequence_count  => $seq_cnt,
            data            => $data,
        };
    }
    else {
        die "message not chunked";
    }
}

sub parse_level {
    my @p = validate_pos(
        @_,
        { type => SCALAR }
    );

    my $level = shift @p;

    if ( $level =~ $LEVEL_NAME_REGEX ) {
        return $LEVEL_NAME_TO_NUMBER{$1};
    }
    elsif ( $level =~ /^(?:0|1|2|3|4|5|6|7)$/ ) {
        return $level;
    }
    else {
        die "level must be between 0 and 7 or a valid log level string";
    }
}

sub parse_size {
    my @p = validate_pos(
        @_,
        {
            type      => SCALAR,
            callbacks => {
                compress_type => sub {
                    my $size = shift;
                    $size =~ /^(?:lan|wan|\d+)$/i
                        or die 'chunk size must be "lan", "wan", a positve integer, or 0 (no chunking)';
                },
            },
        },
    );

    my $size = lc(shift @p);

    # These default values below were determined by
    # examining the code for Graylog's implementation. See
    #  https://github.com/Graylog2/gelf-rb/blob/master/lib/gelf/notifier.rb#L62
    # I believe these are determined by likely MTU defaults
    #  and possible heasers like so...
    # WAN: 1500 - 8 b (UDP header) - 60 b (max IP header) - 12 b (chunking header) = 1420 b
    # LAN: 8192 - 8 b (UDP header) - 20 b (min IP header) - 12 b (chunking header) = 8152 b
    # Note that based on my calculation the Graylog LAN
    #  default may be 2 bytes too big (8154)
    # See http://stackoverflow.com/questions/14993000/the-most-reliable-and-efficient-udp-packet-size
    # For some discussion. I don't think this is an exact science!

    if ( $size eq 'wan' ) {
        $size = 1420;
    }
    elsif ( $size eq 'lan' ) {
        $size = 8152;
    }

    return $size;
}

1;
__END__

=encoding utf-8

=head1 NAME

Log::GELF::Util - Utility functions for Graylog's GELF format.

=head1 SYNOPSIS

    use Log::GELF::Util qw( encode );

    my $msg = encode( { short_message => 'message', } );


    use Log::GELF::Util qw( :all );

    sub process_chunks {

        my @accumulator;
        my $msg;

        do {
            $msg = dechunk(
                \@accumulator,
                decode_chunk(shift())
            );
        } until ($msg);

        return uncompress($msg);
    };

    my $hr = validate_message( short_message => 'message' );

=head1 DESCRIPTION

Log::GELF::Util is a collection of functions and data structures useful
when working with Graylog's GELF Format version 1.1. It strives to support
all of the features and options as described in the L<GELF
specification|http://docs.graylog.org/en/latest/pages/gelf.html>.

=head1 FUNCTIONS

=head2 validate_message( short_message => $ )

Returns a HASHREF representing the validated message with any defaulted
values added to the data structure.

Takes the following message parameters as per the GELF message
specification:

=over

=item short_message

Mandatory string, a short descriptive message

=item version

String, must be '1.1' which is the default.

=item host

String, defaults to hostname() from L<Sys::Hostname>.

=item timestamp

Timestamp, defaults to time() from L<Time::HiRes>.

=item level

Integer, equal to the standard syslog levels, default is 1 (ALERT).

=item facility

Deprecated, a warning will be issued.

=item line

Deprecated, a warning will be issued.

=item file

Deprecated, a warning will be issued.

=item _[additional_field]

Parameters prefixed with an underscore (_) will be treated as an additional
field. Allowed characters in field names are any word character (letter,
number, underscore), dashes and dots. As per the specification '_id' is
disallowed.

=back

=head2 encode( \% )

Accepts a HASHREF representing a GELF message. The message will be
validated with L</validate_message>.

Returns a JSON encoded string representing the message.

=head2 decode( $ )

Accepts a JSON encoded string representing the message. This will be
converted to a hashref and validated with L</validate_message>.

Returns a HASHREF representing the validated message with any defaulted
values added to the data structure.

=head2 compress( $ [, $] )

Accepts a string and compresses it. The second parameter is optional and
can take the value C<zlib> or C<gzip>, defaulting to C<gzip>.

Returns a compressed string.

=head2 uncompress( $ )

Accepts a string and uncompresses it. The compression method (C<gzip> or
C<zlib>) is determined automatically. Uncompressed strings are passed
through unaltered.

Returns an uncompressed string.

=head2 enchunk( $ [, $, $] )

Accepts an encoded message (JSON string) and chunks it according to the
GELF chunking protocol.

The optional second parameter is the maximum size of the chunks to produce,
this must be a positive integer or the special strings C<lan> or C<wan>,
see L</parse_size>. Defaults to C<wan>. A zero chunk size means no chunking
will be applied.

The optional third parameter is the message id used to identify associated
chunks. This must be 8 bytes. It defaults to 8 bytes of randomness generated
by L<Math::Random::MT>.

If the message size is greater than the maximum size then an array of
chunks is retuned, otherwise the message is retuned unaltered as the first
element of an array.

=head2 dechunk( \@, \% )

This facilitates reassembling a GELF message from a stream of chunks.

It accepts an ARRAYREF for accumulating the chunks and a HASHREF
representing a decoded message chunk as produced by L</decode_chunk>.

It returns undef if the accumulator is not complete, i.e. all chunks have
not yet been passed it.

Once the accumulator is complete it returns the de-chunked message in the
form of a string. Note that this message may still be compressed.

Here is an example usage:

    sub process_chunks {

        my @accumulator;
        my $msg;

        do {
            $msg = dechunk(
                \@accumulator,
                decode_chunk(shift())
            );
        } until ($msg);

        return uncompress($msg);
    };

=head2 is_chunked( $ )

Accepts a string and returns a true value if it is a GELF message chunk.

=head2 decode_chunk( $ )

Accepts a GELF message chunk and returns an ARRAYREF representing the
unpacked chunk. Dies if the input is not a GELF chunk.

The message consists of the following keys:

 id
 sequence_number
 sequence_count
 data

=head2 parse_level( $ )

Accepts a C<syslog> style level in the form of a number (1-7) or a string
being one of C<emerg>, C<alert>, C<crit>, C<err>, C<warn>, C<notice>,
C<info>, or C<debug>. Dies upon invalid input.

The string forms may also be elongated and will still be accepted. For
example C<err> and C<error> are equivalent.

The associated syslog level is returned in numeric form.

=head2 parse_size( $ )

Accepts an integer specifying the chunk size or the special string values
C<lan> or C<wan> corresponding to 8154 or 1420 respectively. An explanation
of these values is in the code.

Returns the passed size or the value corresponding to the C<lan> or C<wan>.

L</parse_size> dies upon invalid input.

=head1 CONSTANTS

All Log::Gelf::Util constants are Readonly perl structures. You must use
sigils when referencing them. They can be imported individually and are
included when importing ':all';

=head2 $GELF_MSG_MAGIC

The magic number used to identify a GELF message chunk.

=head2 $ZLIB_MAGIC

The magic number used to identify a Zlib deflated message.

=head2 $GZIP_MAGIC

The magic number used to identify a gzipped message.

=head2 %LEVEL_NAME_TO_NUMBER

A HASH mapping the level names to numbers.

=head2 %LEVEL_NUMBER_TO_NAME

A HASH mapping the level numbers to names.

=head2 %GELF_MESSAGE_FIELDS

A HASH where each key is a valid core GELF message field name. Deprecated
fields are associated with a false value.

=head1 LICENSE

Copyright (C) Strategic Data.

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

=head1 AUTHOR

Adam Clarke E<lt>[e-mail]<gt>

=cut