File Coverage

blib/lib/FusionInventory/Agent/Tools/Network.pm

Criterion	Covered	Total	%
statement	95	109	87.1
branch	29	44	65.9
condition	9	21	42.8
subroutine	18	19	94.7
pod	11	11	100.0
total	162	204	79.4

package FusionInventory::Agent::Tools::Network;

use strict;
use warnings;
use base 'Exporter';

use English qw(-no_match_vars);
use Net::IP qw(:PROC);
use Net::hostent;
use Socket;

use FusionInventory::Agent::Tools;

our @EXPORT = qw(
    $mac_address_pattern
    $ib_mac_address_pattern
    $any_mac_address_pattern
    $ip_address_pattern
    $alt_mac_address_pattern
    $hex_ip_address_pattern
    $network_pattern
    getSubnetAddress
    getSubnetAddressIPv6
    getNetworkMask
    getNetworkMaskIPv6
    isSameNetwork
    isSameNetworkIPv6
    hex2canonical
    alt2canonical
    resolve
    compile
    isPartOf
);

my $dec_byte        = qr/[0-9]{1,3}/;
my $hex_byte        = qr/[0-9A-F]{1,2}/i;
my $padded_hex_byte = qr/[0-9A-F]{2}/i;

our $mac_address_pattern = qr/
    $hex_byte : $hex_byte : $hex_byte : $hex_byte : $hex_byte : $hex_byte
/x;

our $ib_mac_address_pattern = qr/
    $hex_byte : $hex_byte : $hex_byte : $hex_byte : $hex_byte : $hex_byte :
    $hex_byte : $hex_byte : $hex_byte : $hex_byte : $hex_byte : $hex_byte :
    $hex_byte : $hex_byte : $hex_byte : $hex_byte : $hex_byte : $hex_byte :
    $hex_byte : $hex_byte
/x;

our $any_mac_address_pattern = qr/
    (?:$ib_mac_address_pattern|$mac_address_pattern)
/x;

our $ip_address_pattern = qr/
    $dec_byte \. $dec_byte \. $dec_byte \. $dec_byte
/x;

our $alt_mac_address_pattern = qr/
    $padded_hex_byte
    $padded_hex_byte
    $padded_hex_byte
    $padded_hex_byte
    $padded_hex_byte
    $padded_hex_byte
/x;

our $hex_ip_address_pattern = qr/
    $padded_hex_byte
    $padded_hex_byte
    $padded_hex_byte
    $padded_hex_byte
/x;

our $network_pattern = qr/
    $dec_byte (?:\. $dec_byte (?:\. $dec_byte (?:\. $dec_byte)?)?)? \/ \d{1,2}
/x;

sub getSubnetAddress {
    my ($address, $mask) = @_;

    return undef unless $address && $mask; ## no critic (ExplicitReturnUndef)

    my $binaddress = ip_iptobin($address, 4);
    my $binmask    = ip_iptobin($mask, 4);
    my $binsubnet  = $binaddress & $binmask; ## no critic (ProhibitBitwise)

    return ip_bintoip($binsubnet, 4);
}

sub getSubnetAddressIPv6 {
    my ($address, $mask) = @_;

    return undef unless $address && $mask; ## no critic (ExplicitReturnUndef)

    my $binaddress = ip_iptobin(ip_expand_address($address, 6), 6);
    my $binmask    = ip_iptobin(ip_expand_address($mask, 6), 6);
    my $binsubnet  = $binaddress & $binmask; ## no critic (ProhibitBitwise)

    return ip_compress_address(ip_bintoip($binsubnet, 6), 6);
}

sub isSameNetwork {
    my ($address1, $address2, $mask) = @_;

    ## no critic (ExplicitReturnUndef)
    return undef unless $address1 && $address2 && $mask;

    my $binaddress1 = ip_iptobin($address1, 4);
    my $binaddress2 = ip_iptobin($address2, 4);
    my $binmask     = ip_iptobin($mask, 4);

    ## no critic (ProhibitBitwise)
    return ($binaddress1 & $binmask) eq ($binaddress2 & $binmask);
}

sub isSameNetworkIPv6 {
    my ($address1, $address2, $mask) = @_;

    ## no critic (ExplicitReturnUndef)
    return undef unless $address1 && $address2 && $mask;

    my $binaddress1 = ip_iptobin(ip_expand_address($address1, 6), 6);
    my $binaddress2 = ip_iptobin(ip_expand_address($address2, 6), 6);
    my $binmask     = ip_iptobin(ip_expand_address($mask, 6), 6);

    ## no critic (ProhibitBitwise)
    return ($binaddress1 & $binmask) eq ($binaddress2 & $binmask);
}

sub hex2canonical {
    my ($address) = @_;
    return unless $address;

    my @bytes = $address =~ /^(?:0x)?(..)(..)(..)(..)$/;
    return join('.', map { hex($_) } @bytes);
}

sub alt2canonical {
    my ($address) = @_;
    return unless $address;

    my @bytes = $address =~ /^(?:0x)?(..)(..)(..)(..)(..)(..)$/;
    return join(':', @bytes);
}

sub getNetworkMask {
    my ($prefix) = @_;

    return undef unless $prefix; ## no critic (ExplicitReturnUndef)

    return ip_bintoip(ip_get_mask($prefix, 4), 4);
}

sub getNetworkMaskIPv6 {
    my ($prefix) = @_;

    return undef unless $prefix; ## no critic (ExplicitReturnUndef)

    return ip_compress_address(ip_bintoip(ip_get_mask($prefix, 6), 6), 6);
}

sub resolve {
    my ($name, $logger) = @_;

    my @addresses;
    my @errors;

    if ($Socket::VERSION >= 1.94) {
        # IPv6 compatible version
        my ($error, @results) = Socket::getaddrinfo(
            $name, undef, {
                family   => Socket::AF_UNSPEC(),
                protocol => Socket::IPPROTO_TCP()
            }
        );
        if ($error) {
            push @errors, "unable to get address for '$name': $error";
            @results = ();
        }

        # and push all of their addresses in the list
        foreach my $result (@results) {
            my ($error, $address) = Socket::getnameinfo(
                $result->{addr}, Socket::NI_NUMERICHOST()
            );
            if ($error) {
                push @errors,
                    "unable to translate binary address for '$name': $error";
                next;
            }

            # Drop the zone index, as Net::IP does not support it
            $address =~ s/%.*$//;

            push @addresses, $address;
        }
    }

    # If needed, try also legacy resolving and only report previous errors from here
    unless (@addresses) {
        # IPv4-only version
        my $result = gethostbyname($name);
        if (!$result) {
            push @errors,
                "unable to get address for '$name': $ERRNO";
            map { $logger->error($_) } @errors
                if $logger;
            return;
        }
        foreach my $packed_address (@{$result->addr_list()}) {
            push @addresses, inet_ntoa($packed_address);
        }
    }

    return map { Net::IP->new($_) } @addresses;
}

sub compile {
    my ($string, $logger) = @_;

    return unless $string;

    # that's already an IP address, just convert it
    return Net::IP->new($string)
        if $string =~ /^$ip_address_pattern/;

    # otherwise resolve the name
    return resolve($string, $logger);
}

sub isPartOf {
    my ($string, $ranges, $logger) = @_;

    return unless $string;
    return unless $ranges;

    my $address = Net::IP->new($string);

    if (!$address) {
        $logger->error("Not well formatted source IP: $string");
        return;
    }

    foreach my $range (@{$ranges}) {
        my $result = $address->overlaps($range);

        if (!$result && Net::IP::Error()) {
            $logger->debug("Server: ".Net::IP::Error());
            next;
        }

        # included in trusted range
        return 1 if $result == $IP_A_IN_B_OVERLAP;

        # equals trusted address
        return 1 if $result == $IP_IDENTICAL;
    }

    return 0;
}

1;
__END__