File Coverage

blib/lib/Data/Validate/DNS/TLSA.pm

Criterion	Covered	Total	%
statement	96	98	97.9
branch	46	54	85.1
condition	38	51	74.5
subroutine	16	16	100.0
pod	8	8	100.0
total	204	227	89.8

#
# This file is part of Data-Validate-DNS-TLSA
#
# This software is copyright (c) 2018 by Michael Schout.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#

package Data::Validate::DNS::TLSA;
$Data::Validate::DNS::TLSA::VERSION = '0.02';
# ABSTRACT: Validate DNS Transport Layer Security Association (TLSA) Record Values

use strict;
use warnings;

use parent 'Exporter';

use List::Util qw(any);
use Taint::Util qw(untaint);

our @EXPORT_OK = qw(
    is_tlsa_port
    is_tlsa_protocol
    is_tlsa_domain_name
    is_tlsa_selector
    is_tlsa_matching_type
    is_tlsa_cert_usage
    is_tlsa_cert_association);

our %EXPORT_TAGS = (
    all => \@EXPORT_OK);


sub new {
    my $class = shift;
    bless { @_ }, ref $class || $class;
}


sub is_tlsa_port {
    my ($self, $value, %opts) = _maybe_oo(@_);

    $opts{underscore} ||= 0;

    if ($opts{underscore} and substr($value,0,1) ne '_') {
        return;
    }

    (my $port = $value) =~ s/^_//;

    unless ($port =~ /^[1-9][0-9]*$/) {
        return;
    }

    if ($port < 0 or $port > 65535) {
        return;
    }

    untaint($value);

    return $value;
}


sub is_tlsa_protocol {
    my ($self, $value, %opts) = _maybe_oo(@_);

    $opts{underscore} ||= 0;
    $opts{strict}     ||= 0;

    if ($opts{underscore} and substr($value,0,1) ne '_') {
        return;
    }

    (my $proto = $value) =~ s/^_//;

    unless ($proto =~ /^[a-zA-Z]+$/) {
        return;
    }

    if ($opts{strict}) {
        # strict mode, only allow protocols specified in RFC 6698
        unless (any { $_ eq lc($proto) } qw(tcp udp sctp)) {
            return;
        }
    }

    # otherwise, we already checked that its a-Z.
    untaint($value);

    return $value;
}


sub is_tlsa_domain_name {
    my ($self, $value, %opts) = _maybe_oo(@_);

    unless (defined $opts{underscore}) {
        $opts{underscore} = 1;
    }

    my @labels = split /\./, $value;

    if (scalar @labels < 2) {
        return;
    }

    my ($port, $proto) = @labels;

    if (is_tlsa_port($port, %opts) and is_tlsa_protocol($proto, %opts)) {
        untaint($value);
        return $value;
    }

    return;
}


sub is_tlsa_matching_type {
    my ($self, $value, %opts) = _maybe_oo(@_);

    return unless _is_int8($value);

    if ($opts{strict}) {
        # strict mode, only allow registered types
        if (($value >= 0 and $value < 3) or $value == 255) {
            untaint($value);
            return $value;
        }
    }
    else {
        # just a syntax check
        if ($value >= 0 and $value <= 255) {
            untaint($value);
            return $value;
        }
    }

    return;
}


sub is_tlsa_selector {
    my ($self, $value, %opts) = _maybe_oo(@_);

    return unless _is_int8($value);

    if ($opts{strict}) {
        # strict mode, only allow registered selectors
        if (($value >= 0 and $value < 2) or $value == 255) {
            untaint($value);
            return $value;
        }
    }
    else {
        # just a syntax check
        if ($value >= 0 and $value <= 255) {
            untaint($value);
            return $value;
        }
    }

    return;
}


sub is_tlsa_cert_usage {
    my ($self, $value, %opts) = _maybe_oo(@_);

    return unless _is_int8($value);

    if ($opts{strict}) {
        # strict mode, only allow registered values
        if (($value >= 0 and $value < 4) or $value == 255) {
            untaint($value);
            return $value;
        }
    }
    else {
        # just a syntax check
        if ($value >= 0 and $value <= 255) {
            untaint($value);
            return $value;
        }
    }

    return;
}


sub is_tlsa_cert_association {
    my ($self, $value) = _maybe_oo(@_);

    # must contain some hex chars
    if ($value !~ /[0-9a-fA-F]/) {
        return;
    }

    # hex string with white space allowed.
    if ($value =~ /[^0-9a-fA-F\s]/) {
        return;
    }

    untaint($value);

    return $value;
}

sub _is_int8 {
    my $val = shift;

    if ($val =~ /[^0-9]/) {
        return 0;
    }

    if ($val < 0 or $val > 255) {
        return 0;
    }
    else {
        return 1;
    }
}

sub _maybe_oo {
    my $self = shift if ref $_[0];

    return ($self, @_);
}

1;

__END__