package App::OpenVZ::BCWatch;

use strict;
use warnings;
use boolean qw(true false);

use Carp qw(croak);
use File::Basename qw(basename);
use File::HomeDir ();
use File::Spec ();
use Mail::Sendmail qw(sendmail);
use Storable qw(store retrieve);
use Sys::Hostname qw(hostname);

our $VERSION = '0.04';

sub new
{
    my $class = shift;
    my %args = @_;

    my $defined_or = sub { defined $_[0] ? $_[0] : $_[1] };

    my $self = bless {
        Config => {
            input_file      => $args{input_file} || '/proc/user_beancounters',
            data_file       => $args{data_file}  || File::Spec->catfile(File::HomeDir->my_home, 'vzwatchd.dat'),
            _field_names    => [ qw(uid resource held maxheld barrier limit failcnt) ],
            _exclude_fields => [ qw(uid resource) ],
            monitor_fields  => $args{monitor_fields} || [ qw(failcnt) ],
            mail => {
                from    => $args{mail}->{from}    || 'root@localhost',
                to      => $args{mail}->{to}      || 'root@localhost',
                subject => $args{mail}->{subject} || 'vzwatchd: NOTICE',
            },
            sleep   => $defined_or->($args{sleep}, 60),
            verbose => $defined_or->($args{verbose}, false),
            _tests  => $defined_or->($args{_tests}, false),
        }
    }, ref($class) || $class;

    $self->_init;

    return $self;
}

sub process
{
    my $self = shift;

    delete @$self{qw(data stored)};

    $self->_get_data_running;
    $self->_get_data_file;
    $self->_compare_data;
    $self->_put_data_file;
}

sub _init
{
    my $self = shift;

    eval { store({}, $self->{Config}->{data_file}) }
      or croak "Cannot store to $self->{Config}->{data_file}: $!";

    my $pkg_tmpl = join '::', (__PACKAGE__, '_template');
    no strict 'refs';

    if (defined ${$pkg_tmpl}) {
        $self->{template} = ${$pkg_tmpl};
    }
    else {
        ${$pkg_tmpl} = $self->{template} = do {
            local $/ = '__END__';
            local $_ = <DATA>;
            chomp;
            s/^\s+//;
            s/\s+\z//;
            $_
        };
    }

    $self->{excluded} = {
        map {
          my $field = $_;
            (scalar grep $_ eq $field, @{$self->{Config}->{_exclude_fields}})
              ? ($field => true)
              : ($field => false)
        } @{$self->{Config}->{_field_names}}
    };

    my $i;
    $self->{index} = { map { $_ => $i++ } @{$self->{Config}->{_field_names}} };
}

sub _get_data_running
{
    my $self = shift;

    open(my $fh, '<', $self->{Config}->{input_file})
      or croak "Cannot read $self->{Config}->{input_file}: $!";
    my $output = do { local $/; <$fh> };
    close($fh);

    my $valid_format = join '\s+', @{$self->{Config}->{_field_names}};

    unless ($output =~ /$valid_format/) {
        croak "Format of $self->{Config}->{input_file} not recognized";
    }

    my $re = qr{
                      \s*?
         (?:\d+?\:)?  \s+?
         (?:\w+?)     \s+?
         (?:(?:\d+?)  \s*?){5}
    }x;

    my $uid;

    my @names = grep {
      !$self->{excluded}->{$_}
        ? $_ : ()
    } @{$self->{Config}->{_field_names}};

    local $1;
    while ($output =~ /^($re)$/gm) {
        my $line = $1;
        if ($line =~ /^ \s+? (\d+?)\:/gx) {
            $uid = $1;
        }
        my $res;
        if ($line =~ /\G \s+? (\w+)/gx) {
            $res = $1;
        }
        my @fields;
        if ($line =~ /\G \s+ (.*) $/x) {
            @fields = split /\s+/, $1;
        }
        push @{$self->{data}{$uid}{$res}},
          { map { $names[$_] => $fields[$_] } (0 .. $#fields) };
    }
}

sub _get_data_file
{
    my $self = shift;

    eval { $self->{stored} = retrieve($self->{Config}->{data_file}) }
      or croak "Cannot retrieve from $self->{Config}->{data_file}: $!";
}

sub _compare_data
{
    my $self = shift;

    my $has_changed = sub
    {
        my ($uid, $res, $i) = @_;

        my ($data, $stored) = map {
          my $type = $_; sub { $self->{$type}{$uid}{$res}->[$i]->{$_[0]} || 0 }
        } qw(data stored);

        return scalar grep { $data->($_) > $stored->($_) } @{$self->{Config}->{monitor_fields}};
    };

    foreach my $uid (sort {$a <=> $b} keys %{$self->{stored}}) {
        foreach my $res (sort {$a cmp $b} keys %{$self->{stored}{$uid}}) {
            foreach my $index (0 .. $#{$self->{stored}{$uid}{$res}}) {
                if ($has_changed->($uid, $res, $index)) {
                    $self->_create_report($uid, $res, $index);
                }
            }
        }
    }
}

sub _create_report
{
    my $self = shift;
    my ($uid, $res, $index) = @_;

    if ($self->{Config}->{_tests}) {
        push @{$self->{tests}->{report}}, $self->_prepare_report($uid, $res, $index);
    }
    else {
        my $report = $self->_prepare_report($uid, $res, $index);
        $self->_send_mail($report);

        if ($self->{Config}->{verbose}) {
            print "Report for \"$uid: $res\" sent to '$self->{Config}->{mail}->{to}'\n";
        }
    }
}

sub _put_data_file
{
    my $self = shift;

    eval { store($self->{data}, $self->{Config}->{data_file}) }
      or croak "Cannot store to $self->{Config}->{data_file}: $!";
}

sub _prepare_report
{
    my $self = shift;
    my ($uid, $res, $index) = @_;

    my @fixed_fields = ($uid, $res) x 2;
    my @mapping = (
        [
          { map {
            $_ => shift @fixed_fields,
          } @{$self->{Config}->{_exclude_fields}} },
          { map {
            $_ => $self->{stored}{$uid}{$res}->[$index]->{$_},
          } grep !$self->{excluded}->{$_}, @{$self->{Config}->{_field_names}} }
        ],
        [
          { map {
            $_ => shift @fixed_fields,
          } @{$self->{Config}->{_exclude_fields}} },
          { map {
            $_ => $self->{data}{$uid}{$res}->[$index]->{$_},
          } grep !$self->{excluded}->{$_}, @{$self->{Config}->{_field_names}} }
        ],
    );

    my @values;
    foreach my $map (@mapping) {
        my @v;
        foreach my $entry (@$map) {
            push @v, map $entry->{$_}, sort {
              $self->{index}->{$a} <=> $self->{index}->{$b}
            } keys %$entry;
        }
        push @values, [ @v ];
    }

    my %changed;
    foreach my $field (keys %{$mapping[0]->[1]}) {
        if ($mapping[0]->[1]->{$field} != $mapping[1]->[1]->{$field}) {
            $changed{$self->{index}->{$field}} = true;
        }
    }

    my $tmpl = \@values;
    my $report = $self->{template};

    local $1;

    while (my ($var) = $report =~ /(\$\S+)/) {
        unless ($report =~ /\Q$var\E$/m) {
            my $len = length($var) - length do { eval $var };
            $report =~ s/(?<=\Q$var\E)/' ' x $len/e;
        }
        $report =~ s/(\Q$var\E)/$1/ee;
    }

    while (my ($pos) = $report =~ /\((\d+)\)/) {
        my $marked = $changed{$pos} ? '*' : ' ';
        $report =~ s/\($pos\)/  $marked/;
    }

    return $report;
}

sub _send_mail
{
    my $self = shift;
    my ($report) = @_;

    my %mail = (
        From    => $self->{Config}->{mail}->{from},
        To      => $self->{Config}->{mail}->{to},
        Subject => $self->{Config}->{mail}->{subject},
        Message => <<EOT,
${\hostname}

$report

-- 
${\basename($0)} v$VERSION - ${\scalar localtime}
EOT
);
    sendmail(%mail)
      or croak "Cannot send mail: $Mail::Sendmail::error";
}

1;
__DATA__

Old:                          New:
----                          ----
Uid: $tmpl->[0][0]        (0) Uid: $tmpl->[1][0]
Res: $tmpl->[0][1]        (1) Res: $tmpl->[1][1]
Held: $tmpl->[0][2]       (2) Held: $tmpl->[1][2]
Maxheld: $tmpl->[0][3]    (3) Maxheld: $tmpl->[1][3]
Barrier: $tmpl->[0][4]    (4) Barrier: $tmpl->[1][4]
Limit: $tmpl->[0][5]      (5) Limit: $tmpl->[1][5]
Failcnt: $tmpl->[0][6]    (6) Failcnt: $tmpl->[1][6]

__END__

=head1 NAME

App::OpenVZ::BCWatch - Monitor the OpenVZ user_beancounters file

=head1 SYNOPSIS

 use App::OpenVZ::BCWatch;

 $watch = App::OpenVZ::BCWatch->new;
 $watch->process;

=head1 DESCRIPTION

C<App::OpenVZ::BCWatch> monitors the F</proc/user_beancounters> file and sends
mail notifications whenever important values change (as defined by the user).

The recommended usage of this application module is to use the provided
L<vzwatchd> daemon.

Version 2.5 of the F<user_beancounters> file is supported.

=head1 CONSTRUCTOR

=head2 new

 $watch = App::OpenVZ::BCWatch->new;

Instantiate an C<App::OpenVZ::BCWatch> object.

=head1 METHODS

=head2 process

 $watch->process;

Inspect whether the F<user_beancounters> file differs from the last run,
and if, report the differences via mail.

=head1 DAEMON USAGE

Run L<vzwatchd> as root without arguments to obtain a list of commands.

=head1 CONFIGURATION FILE

When L<vzwatchd> is I<started> initially, the F</etc/vzwatchd.conf> file
will be generated. The configuration will then subsequently remain inactive
until the C<_active> flag is either set within or deleted from the
configuration file.

=head2 Syntax

The configuration file is being parsed by L<Config::File>. Unless noted
otherwise, each option takes exactly one value. Specifying more than one
value for an option requires that the values are separated by whitespace.

=head2 Options

Adjustable options with defaults are:

=over 4

=item * C<mail[from]>

Mail sender address. Defaults to C<root@localhost>.

=item * C<mail[to]>

Mail recipient address. Defaults to C<root@localhost>.

=item * C<mail[subject]>

Mail subject line. Defaults to: C<vzwatchd: NOTICE>.

=item * C<monitor_fields>

One or more field names to monitor for changes. Defaults to: C<failcnt>.

=item * C<sleep>

Sleep interval in seconds. Defaults to 60.

=item * C<verbose>

Be verbose? Defaults to false.

=item * C<_active>

Configuration active? Defaults to false.

=back

Additional options with defaults are:

=over 4

=item * C<input_file>

Location of the F<user_beancounters> file. Defaults to F</proc/user_beancounters>.

=item * C<data_file>

Location of the data file. Defaults to F<$HOME/vzwatchd.dat>.

=back

=head1 CURRENT LIMITATIONS

=over 4

=item * Cannot parse anything else than the F<user_beancounters> file.

=item * Only version 2.5 of the F<user_beancounters> file is known to work.

=item * Fixed mail report template.

=item * No more than one mail recipient.

=back

=head1 BUGS & CAVEATS

Note that the sender and recipient mail address options with defaults
might require adjustment in order for notifications to be delivered.

=head1 SEE ALSO

L<OpenVZ::BC>, L<http://openvz.org>

=head1 AUTHOR

Steven Schubiger <schubiger@cpan.org>

=head1 LICENSE

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

See L<http://dev.perl.org/licenses/>

=cut