File Coverage

blib/lib/Logwatch/RecordTree/IPv4.pm

Criterion	Covered	Total	%
statement	148	152	97.3
branch	31	40	77.5
condition	12	15	80.0
subroutine	23	23	100.0
pod	4	11	36.3
total	218	241	90.4

#!/usr/bin/perl
#===============================================================================
#      PODNAME:  Logwatch::RecordTree::IPv4
#     ABSTRACT:  a subclass of Logwatch::RecordTree for IPv4 addresses
#
#       AUTHOR:  Reid Augustin (REID)
#        EMAIL:  [e-mail]
#      CREATED:  Thu Mar 12 18:41:04 PDT 2015
#===============================================================================

use 5.008;
use strict;
use warnings;

package Logwatch::RecordTree::IPv4;
use parent 'Logwatch::RecordTree';
use Moo;
use UNIVERSAL::require;
# use Net::IP::Identifier 0.111
use Carp qw( croak );
use Sort::Key::IPv4;
use Sort::Key::Natural qw( natsort natkeysort );
use Math::BigInt;

our $VERSION = '2.056'; # VERSION

has identify => (
    is => 'rw',
);
has snowshoe => (   # number indicating width of mask to consider.  1 => 24
    is => 'rw',
);

my $identifier;  # class variable

sub identifier {
    my ($self) = @_;

    if (not $self->{identifier}) {
        if (not $identifier) {
            Net::IP::Identifier->require(0.111)
                or croak($@);
            $identifier = Net::IP::Identifier->new;
        }
        $self->{identifier} = $identifier;
    }
    return $self->{identifier};
}

sub create_child { # override
    my ($self, $name, $type, $opts) = @_;

    my $child = $self->SUPER::create_child($name, $type, $opts);

    # this is why we're overriding parent's create_child method.  we want
    #    to do these when child is created so caller can make changes
    $child->sprint_name(sub {
        my ($child) = @_;

        my $ip = $child->name;
        if ($self->identify and
            ($ip =~ m/^\d+\.\d+\.\d+\.\d+(\/\d+)?$/ or
             $ip =~ m/^[\d:]+(\/\d+)?$/)) {
            my $id = $self->identifier->identify($ip);
            if ($id) {
                $id = substr($id, 0, 8) if (length $id > 8);
                $ip = "$id-$ip";
            }
        }
        return $ip;
    });

    return $child;
}

# the IP list may contain non-IP addresses, split into two lists:
sub split_ips {
    my ($self, $ips_orig) = @_;

    my (@non_ips, @ips);
    for my $ip (@{$ips_orig}) {
        if ($ip =~ m/^\d+\.\d+\.\d+\.\d+(\/\d+)?$/ or
            $ip =~ m/^[\d:]+(\/\d+)?$/) {
            push @ips, $ip;
        }
        else {
            push @non_ips, $ip;
        }
    }
    return (\@non_ips, \@ips);
}

# sort a list of hosts which may include non-IP addresses
sub ipv4sort {
    my ($self, @ips_orig) = @_;

    my ($non_ips, $ips) = $self->split_ips(\@ips_orig);
    my $case_sensitive = ref $self ? $self->case_sensitive : 0;
    @{$non_ips} = $case_sensitive
      ? natsort @{$non_ips}
      : natkeysort { lc $_ } @{$non_ips};

    my %ips;
    for my $ip (@{$ips}) {
        my ($key) = $ip =~ m/([^\/]+)/;   # key on just the IP part without range
        $ips{$key} = $ip;
    }
    my @sorted_keys = Sort::Key::IPv4::ipv4sort(keys %ips);
    my @ips = map { $ips{$_} } @sorted_keys;

    return (@{$non_ips}, @ips);
}

sub sort_children {
    my ($self) = @_;

    my %keys = map { (defined($_->sort_key) ? $_->sort_key : $_->name) => $_ }
                   values %{$self->children};
    my @children = map { $keys{$_} } $self->ipv4sort(keys %keys);

    return wantarray
        ?  @children
        : \@children;
}

sub sprint {
    my ($self, @args) = @_;

    if ($self->snowshoe) {
        # create new child list and replace the old list
        $self->children($self->condense_snowshoes);
    }
    return $self->SUPER::sprint(@args);
}

# convert decimal dotted quad to binary IP
sub ip_to_bin {
    my ($self, $ip) = @_;

    my $bin = Math::BigInt->new(0);
    for my $part (split '\.', $ip) {
        $bin <<= 8;
        $bin |= $part;
    }
    return $bin
}

# convert binary IP to decimal dotted quad
sub bin_to_ip {
    my ($self, $bin) = @_;

    my @parts;
    while (@parts < 4) {
        unshift @parts, $bin & 0xff;
        $bin >>= 8;
    }
    return join('.', @parts);
}

# return a mask of $width
sub mask {
    my ($self, $width) = @_;

    return Math::BigInt->new(1)->blsft($width)->bsub(1)->blsft(32-$width);
}

sub min_range {
    my ($self, $group) = @_;    # group is ordered list of Logwatch::RecordTrees with IPs as names

    my $width = 32;
    my $mask = $self->mask($width); # full width mask to start

    my $masked_ip = $self->ip_to_bin($group->[0]->name);
    for my $item (@{$group}) {
        my $ip = $self->ip_to_bin($item->name);
        while ($width) {
            last if (($ip & $mask) == $masked_ip);
            $mask &= $mask->blsft(1);
            $width--;
            $masked_ip &= $mask;
        }
    }
    return $self->bin_to_ip($masked_ip). "/$width";
}

# hackers often rent IP blocks (/24 is common) so the source IP isn't
# exactly duplicated.  Collect IPs within a block into single child.
sub condense_snowshoes {
    my ($self) = @_;

    my $mask_width = $self->snowshoe;
    # mask width of 1 is pretty useless, so we'll interpret it as /24:
    $mask_width = 24 if ($mask_width == 1);
    my $mask = $self->mask($mask_width);

    my ($non_ips, $ips) = $self->split_ips([keys %{$self->children}]);
    @{$ips} = Sort::Key::IPv4::ipv4sort(@{$ips});

    my ($masked_ip, $count, @group, %new_children);
    for my $ip (@{$ips}, '') {   # add dummy at end to flush
        my $child;
        $child = $self->child_by_name($ip) if ($ip);
        if ($masked_ip) {   # skip the first time through
            if ($ip and
                $masked_ip == ($self->ip_to_bin($ip) & $mask)) {  # in range?
                $count += $child->count;
                push @group, $child;
            }
            else { # out of range (or last time through the loop with dummy)
                if (@group < 3) {   # require at least three before condensing
                    map { $new_children{$_->name} = $_ } @group;    # copy to new list
                }
                else {
                    my $name = $self->min_range(\@group);
                    my $new_child
                      = $new_children{$name}
                      = $group[0]->new(  # clone first child
                        name         => $name,
                        sprint_name  => $group[0]->sprint_name,
                        count_fields => [ '/', scalar @group ],
                    );
                    # transfer any children from group items to new parent
                    for my $item (@group) {
                        my @g_children = values %{$item->children};
                        if (@g_children) {
                            for my $child (@g_children) {
                                $new_child->adopt($child);
                            }
                        }
                        else {  # no children, count is entirely from item
                            $new_child->count($new_child->count + $item->count);
                        }
                    }
                }
                undef $masked_ip;    # start a new range
            }
        }
        if ($ip and not $masked_ip) {
            $masked_ip = $self->ip_to_bin($ip) & $mask;
            @group = ( $self->child_by_name($ip) );
            $count = $child->count;
        }
    }

    # rejoin the non-IP children
    map { $new_children{$_} = $self->child_by_name($_) } @{$non_ips};

    $self->children(\%new_children);
}

1;

__END__