Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

213 lines (160 sloc) 4.606 kB
#!/usr/bin/perl
use strict;
use warnings;
use autodie;
use Courriel::Builder;
use DateTime;
use DateTime::TimeZone;
use Email::Sender::Simple qw( sendmail );
use IO::Async::FileStream;
use IO::Async::Loop;
use Try::Tiny;
use VegGuide::Config;
use VegGuide::JSON;
use Getopt::Long;
my $file = '/var/log/vegguide/error.log';
my $hostname = VegGuide::Config->Hostname();
my $from = 'log-monitor@' . $hostname;
my $local_tz = DateTime::TimeZone->new( name => 'local' );
sub main {
my $debug;
GetOptions( 'debug' => \$debug );
my @messages;
open my $log_fh, '<', $file;
my $on_read = _on_read_callback( \@messages, $debug );
my $tail = IO::Async::FileStream->new(
read_handle => $log_fh,
on_initial => sub {
my $self = shift;
$self->seek_to_last("\n");
},
on_read => $on_read,
);
my $timer = IO::Async::Timer::Periodic->new(
interval => ( $debug ? 5 : 5 * 60 ),
on_tick => _on_tick_callback( \@messages, $debug ),
);
my $loop = IO::Async::Loop->new();
$loop->add($tail);
$timer->start();
$loop->add($timer);
$loop->loop_forever();
}
sub _on_read_callback {
my $messages = shift;
my $debug = shift;
my $record = q{};
my $in_record = 0;
return sub {
shift;
my $buffer = shift;
while ( ${$buffer} =~ s/^(.*)\n// ) {
my $line = $1;
warn "[$line]\n" if $debug;
next if _skip($line);
if ( $line =~ /^{/ ) {
$in_record = 1;
$record .= '{';
}
elsif ($in_record) {
$record .= $line;
if ( $line =~ /^}/ ) {
my $message;
try {
push @{$messages}, _process_record($record);
}
catch {
warn $_ if $debug;
};
$in_record = 0;
$record = q{};
}
}
else {
push @{$messages}, { text => $line };
}
}
};
}
sub _skip {
my $line = shift;
return 1 unless $line =~ /\S/;
return 1 if $line =~ /\QSubroutine finalize_error redefined/;
return 1 if $line =~ /\QStarman::Server (type Net::Server::PreFork) starting/;
return 1 if $line =~ /\QUsing default listen value of/;
return 1 if $line =~ /\QBinding to TCP port/;
return 1 if $line =~ /\QSetting gid to/;
return 1 if $line =~ /\QSetting uid to/;
return 1 if $line =~ /\QServer closing!/;
return 0;
}
my %key_order = (
uri => 1,
user => 2,
referer => 3,
user_agent => 4,
);
sub _process_record {
my $record = shift;
my $decoded = VegGuide::JSON->Decode($record);
my $epoch = delete $decoded->{epoch};
my $error_message = delete $decoded->{error};
my $text = q{};
for my $key (
sort {
( $key_order{$a} // 5 ) <=> ( $key_order{$b} // 5 )
or $a cmp $b
} keys %{$decoded}
) {
$text .= sprintf( '%-11s: %s', _titleize($key), $decoded->{$key} );
$text .= "\n";
}
$text .= $error_message;
$text =~ s/^\s*/ /gm;
my $dt = DateTime->from_epoch(
epoch => $epoch,
time_zone => $local_tz,
);
return { date => $dt, text => $text };
}
sub _titleize {
my $key = shift;
return 'URI' if $key eq 'uri';
return join '-', map { ucfirst } split /_/, $key;
}
sub _on_tick_callback {
my $messages = shift;
my $debug = shift;
return sub {
warn 'We have ' . ( scalar @{$messages} ) . " message(s) to send\n" if $debug;
return unless @{$messages};
my $sep = "\n\n";
$sep .= '-' x 80;
$sep .= "\n\n";
my $body = join $sep, map { _format_message($_) } @{$messages};
my $email = build_email(
from($from),
to('autarch@urth.org'),
subject("VegGuide ($hostname) log errors"),
plain_body($body),
);
try {
sendmail($email);
}
catch {
warn $_ if $debug;
};
@{$messages} = ();
};
}
sub _format_message {
my $message = shift;
my $formatted = q{};
if ( $message->{date} ) {
$formatted .= $message->{date}->strftime('%Y-%m-%d %H:%M:%S');
$formatted .= "\n";
}
$formatted .= $message->{text};
return $formatted;
}
main();
Jump to Line
Something went wrong with that request. Please try again.