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


line stmt bran cond sub pod time code
1             # ABSTRACT: Client for Graylog2 analysis server
2              
3              
4             package Net::Graylog::Client;
5             {
6             $Net::Graylog::Client::VERSION = '0.4';
7             }
8              
9 1     1   180936 use strict;
  1         4  
  1         37  
10 1     1   9 use warnings;
  1         2  
  1         35  
11 1     1   5 use POSIX qw(strftime);
  1         4  
  1         8  
12 1     1   57 use Data::Printer;
  1         2  
  1         9  
13 1     1   420 use Furl;
  1         14650  
  1         29  
14 1     1   422 use JSON::Tiny qw(encode_json);
  1         1970  
  1         50  
15 1     1   364 use Sys::Hostname;
  1         813  
  1         43  
16 1     1   6 use Data::UUID;
  1         2  
  1         46  
17 1     1   6 use POSIX qw(strftime);
  1         2  
  1         6  
18 1     1   51 use App::Basis;
  1         2  
  1         87  
19              
20             # use Mo qw( default is required ); # not using (build builder coerce)
21 1     1   5 use Moo;
  1         2  
  1         9  
22 1     1   816 use namespace::clean;
  1         4655  
  1         6  
23              
24 1     1   440 use vars qw( @EXPORT @ISA);
  1         6  
  1         60  
25              
26             # -----------------------------------------------------------------------------
27              
28             @ISA = qw(Exporter);
29              
30             # this is the list of things that will get imported into the loading packages
31             # namespace
32             @EXPORT = qw(
33             valid_levels
34             valid_facilities
35             );
36              
37 1     1   9 use constant GELF_VERSION => "1.1";
  1         2  
  1         680  
38              
39             # -----------------------------------------------------------------------------
40              
41              
42              
43             has url => ( is => 'ro', required => 1 );
44             has _uuid => ( is => 'ro', init_arg => undef, default => sub { Data::UUID->new() }, );
45             has _hostname => ( is => 'ro', init_arg => undef, default => sub { hostname(); } );
46             has timeout => ( is => 'ro', default => sub { 0.01; } );
47              
48             # we need to set a timeout for the connection as Furl seems to wait
49             # for this time to elapse before giving us any response. If the default is used
50             # 180s then this will block for 3 minutes! crazy stuff, so I set it to 0.01
51             # which would allow me to send 100 messages/sec, which should be OK for my
52             # purposes especially as my graylog is on the local network
53             has _furl => (
54             is => 'lazy',
55             default => sub {
56             my $self = shift;
57             return Furl->new(
58             agent => __PACKAGE__,
59              
60             # headers => [
61             # 'Accept' => 'application/json',
62             # 'content-type' => 'application/json',
63             # ],
64             timeout => $self->timeout,
65             );
66             },
67             init_arg => undef,
68             );
69              
70             # -----------------------------------------------------------------------------
71              
72             # these are the syslog severity levels
73             my @msg_levels = qw( emerg alert crit error warning notice info debug);
74             my $_mc = 0;
75             my %msg_lvalues = map { $_ => $_mc++; } @msg_levels;
76              
77             # some levels have alternate names
78             my %msg_tx = ( panic => 'emerg', err => 'error', warn => 'warning' );
79              
80             my @msg_facilities = qw(
81             kern user mail daemon auth syslog lpr news
82             uucp clock authpriv ftp ntp audit alert cron
83             local0 local1 local2 local3 local4 local5 local6 local7
84             );
85             my $_mf = 0;
86             my %msg_fvalues = map { $_ => $_mf++; } @msg_facilities;
87              
88             # -----------------------------------------------------------------------------
89              
90              
91             sub send {
92 0     0 1   my $self = shift;
93 0           my (%data) = @_;
94              
95             # we add these fields so, we will report issues if they are passed
96             # for some reason graylog accepts a message with a count field
97             # but then silently discards it!
98 0 0         map { die "Field '$_' not allowed" if ( $data{$_} ) } qw( uuid timestamp timestr count);
  0            
99              
100 0 0         die "message field is required" if ( !$data{message} );
101              
102 0           $data{version} = GELF_VERSION;
103 0           $data{short_message} = $data{message};
104 0   0       $data{full_message} = $data{long} || $data{full_message};
105 0           $data{uuid} = $self->_uuid->create_str();
106 0           $data{timestamp} = time();
107 0           $data{timestr} = strftime( "%Y-%m-%d %H:%M:%S", gmtime( time() ) );
108 0   0       $data{host} = $data{server} || $data{host} || hostname();
109 0   0       $data{logger} ||= get_program();
110              
111             # convert the level to match a syslog level and stop graylog fretting
112 0 0 0       if ( defined $data{level} && $data{level} !~ /^\d+$/ ) {
113              
114             # convert the level into a number
115 0           my $l = $data{level};
116              
117             # get the alternate name if needed
118 0 0         $l = $msg_tx{ $data{level} } if ( $msg_tx{ $data{level} } );
119 0 0         if ( defined $msg_lvalues{$l} ) {
120 0           $data{level} = $msg_lvalues{$l};
121              
122             # also save as a string for user to reference
123 0           $data{levelstr} = $l;
124             }
125             }
126              
127             # remove some entries we dont want
128 0 0         map { delete $data{$_} if ( exists $data{$_} ); } qw( server message long);
  0            
129              
130             # rename things that are not allowed fields
131 0           my %allowed = map { $_ => 1 } qw(uuid timestamp host version timestr full_message short_message level facility file);
  0            
132 0           foreach my $k ( keys %data ) {
133 0 0         if ( !$allowed{$k} ) {
134              
135             # prefix with an underline and then remove original
136 0           $data{"_$k"} = $data{$k};
137 0           delete $data{$k};
138             }
139             }
140              
141             # convert any floats into strings
142             # foreach my $k ( keys %data) {
143             # # floating point numbers need to be made into strings
144             # if( $data{$k} =~ /^[0-9]{1,}(\.[0-9]{1,})$/) {
145             # $data{$k} = "" . $data{$k} ;
146             # }
147             # }
148              
149 0           my $status = $self->_furl->post( $self->url, [ 'Content-Type' => 'application/json' ], encode_json( \%data ) );
150              
151 0           return ( $status->is_success, $status->code );
152             }
153              
154             # -----------------------------------------------------------------------------
155              
156              
157             sub AUTOLOAD {
158              
159             # we use AUTOLOAD to handle some aliases for send
160              
161             # find out if this is a name we alias
162 0     0     my $level = our $AUTOLOAD;
163 0           $level =~ s/.*:://; # strip the package name
164 0 0         if ( !defined $msg_lvalues{$level} ) {
165 0           die qq(Can't locate object method $level via package "@{[__PACKAGE__]}");
  0            
166             }
167              
168 0           my $self = shift;
169 0           my %params = @_;
170              
171             # set the level field
172 0           $params{level} = $level;
173              
174             # and perform the actual send
175 0           return $self->send(%params);
176             }
177              
178             # -----------------------------------------------------------------------------
179              
180             sub DESTROY {
181 0     0     return 1;
182             }
183              
184             # -----------------------------------------------------------------------------
185              
186              
187             sub valid_levels {
188 0     0 1   return @msg_levels;
189             }
190              
191             # -----------------------------------------------------------------------------
192              
193              
194             sub valid_facilities {
195 0     0 1   return @msg_facilities;
196             }
197              
198              
199             # -----------------------------------------------------------------------------
200             1;
201              
202             __END__