File Coverage

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

Criterion	Covered	Total	%
statement	60	62	96.7
branch	20	24	83.3
condition	1	3	33.3
subroutine	15	15	100.0
pod	6	6	100.0
total	102	110	92.7

package Data::Validate::DNS::CAA;
$Data::Validate::DNS::CAA::VERSION = '0.04';
# ABSTRACT: Validate DNS Certification Authority Authorization (CAA) values

use 5.010;
use strict;
use warnings;

use base 'Exporter';

use Syntax::Keyword::Junction qw(any);
use Data::Validate::URI qw(is_web_uri);
use Data::Validate::Email qw(is_email);
use Taint::Util qw(untaint);

our @EXPORT_OK = qw(
    is_caa_tag
    is_caa_value
    is_caa_issue
    is_caa_iodef
    is_caa_issuewild);


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


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

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

    if ($opts{strict}) {
        # strict mode, only allow registered tag names
        if (lc $value eq any(qw(issue issuewild iodef))) {
            untaint($value);

            return $value;
        }
    }
    else {
        # just a syntax check
        unless ($value =~ /[^a-zA-Z0-9]/) {
            untaint($value);

            return $value;
        }
    }

    return;
}


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

    $tag = lc $tag;

    if ($tag eq 'issue') {
        return is_caa_issue($value);
    }
    elsif ($tag eq 'issuewild') {
        return is_caa_issue($value);
    }
    elsif ($tag eq 'iodef') {
        return is_caa_iodef($value);
    }

    return;
}


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

    # match using grammar from RFC 6844
    my $issue_re = qr{
        (?&issueval)
        (?(DEFINE)
            (?    \s* (?&domain)? \s* (?&tagstring)? )
            (?      (?&label) (?: . (?&label) )* )
            (?       [0-9a-zA-Z] (?: \-* [0-9A-Za-z] )* )
            (?   ; (?: \s* (?¶meter) )* \s* )
            (?   [0-9A-Za-z]+ = [\x21-\x7e]* )
        )
    }x;

    if ($value =~ qr/^$issue_re$/) {
        untaint($value);

        return $value;
    }

    return;
}


sub is_caa_issuewild {
    return is_caa_issue(@_);
}


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

    # handle http/https uris
    if (is_web_uri($value)) {
        untaint($value);

        return $value;
    }

    if (lc $value =~ /^mailto:\S+@\S+/) {
        $value =~ s/^mailto://;

        if (is_email($value)) {
            untaint($value);

            return $value;
        }
    }

    return;
}

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

    return ($self, @_);
}

1;

__END__