view release on metacpan or  search on metacpan

lib/Mail/DMARC/Policy.pm  view on Meta::CPAN

            if ( !$warned ) {

                #warn "tv: $tv\n";
                warn "invalid DMARC record, please post this message to\n"
                    . "\thttps://github.com/msimerson/mail-dmarc/issues/39\n"
                    . "\t$str\n";
            }
            $warned++;
            next;
        }
        $policy{ lc $tag } = $value;
    }

    # RFC 9989: an unrecognized value for an optional tag is ignored (the tag
    # reverts to its default); it MUST NOT invalidate the whole record. The
    # setters croak, so normalize here on the parse-from-DNS path instead.
    if ( defined $policy{psd} && $policy{psd} !~ /^[ynu]$/i ) {
        warn "ignoring invalid psd ($policy{psd})\n";
        delete $policy{psd};
    }
    if ( defined $policy{t} && $policy{t} !~ /^[yn]$/i ) {
        warn "ignoring invalid t ($policy{t})\n";
        delete $policy{t};
    }

    return bless \%policy, ref $self;    # inherited defaults + overrides
}

sub stringify($self) {
    my %dmarc_record = %{$self};
    delete $dmarc_record{domain};

    my $dmarc_txt = 'v=' . ( delete $dmarc_record{v} );    # "v" tag must be first
    foreach my $key ( keys %dmarc_record ) {
        $dmarc_txt .= "; $key=$dmarc_record{$key}";
    }
    return $dmarc_txt;
}

sub apply_defaults($self) {
    $self->adkim('r') if !defined $self->adkim;
    $self->aspf('r')  if !defined $self->aspf;
    $self->fo(0)      if !defined $self->fo;

    # rf, ri, pct are deprecated in DMARCbis (RFC 9989) and MUST be ignored
    return 1;
}

sub v( $self, $val = undef ) {
    return $self->{v}                 if @_ == 1;
    croak "unsupported DMARC version" if 'DMARC1' ne uc $val;
    return $self->{v} = $val;
}

sub p( $self, $val = undef ) {
    return $self->{p} if @_ == 1;
    croak "invalid p" if !$self->is_valid_p($val);
    return $self->{p} = $val;
}

sub sp( $self, $val = undef ) {
    return $self->{sp}        if @_ == 1;
    croak "invalid sp ($val)" if !$self->is_valid_p($val);
    return $self->{sp} = $val;
}

sub np( $self, $val = undef ) {
    return $self->{np}        if @_ == 1;
    croak "invalid np ($val)" if !$self->is_valid_p($val);
    return $self->{np} = $val;
}

sub psd( $self, $val = undef ) {
    return $self->{psd}        if @_ == 1;
    croak "invalid psd ($val)" if 0 == grep {/^\Q$val\E$/i} qw/ y n u /;
    return $self->{psd} = lc $val;
}

sub t( $self, $val = undef ) {
    return $self->{t}        if @_ == 1;
    croak "invalid t ($val)" if 0 == grep {/^\Q$val\E$/i} qw/ y n /;
    return $self->{t} = lc $val;
}

sub adkim( $self, $val = undef ) {
    return $self->{adkim} if @_ == 1;
    croak "invalid adkim" if 0 == grep {/^\Q$val\E$/ix} qw/ r s /;
    return $self->{adkim} = $val;
}

sub aspf( $self, $val = undef ) {
    return $self->{aspf} if @_ == 1;
    croak "invalid aspf" if 0 == grep {/^\Q$val\E$/ix} qw/ r s /;
    return $self->{aspf} = $val;
}

sub fo( $self, $val = undef ) {
    return $self->{fo}       if @_ == 1;
    croak "invalid fo: $val" if $val !~ /^[01ds](:[01ds])*$/ix;
    return $self->{fo} = $val;
}

sub rua( $self, $val = undef ) {
    return $self->{rua} if @_ == 1;
    croak "invalid rua" if !$self->is_valid_uri_list($val);
    return $self->{rua} = $val;
}

sub ruf( $self, $val = undef ) {
    return $self->{ruf} if @_ == 1;
    croak "invalid rua" if !$self->is_valid_uri_list($val);
    return $self->{ruf} = $val;
}

sub rf( $self, $val = undef ) {
    return $self->{rf} if @_ == 1;
    foreach my $f ( split /,/, $val ) {
        croak "invalid format: $f" if !$self->is_valid_rf($f);
    }
    return $self->{rf} = $val;
}

sub ri( $self, $val = undef ) {
    return $self->{ri}          if @_ == 1;
    croak "not numeric ($val)!" if $val =~ /\D/;
    croak "not an integer!"     if $val != int $val;
    croak "out of range"        if ( $val < 0 || $val > 4294967295 );
    return $self->{ri} = $val;
}

sub pct( $self, $val = undef ) {
    return $self->{pct}         if @_ == 1;
    croak "not numeric ($val)!" if $val =~ /\D/;
    croak "not an integer!"     if $val != int $val;
    croak "out of range"        if $val < 0 || $val > 100;
    return $self->{pct} = $val;
}

sub domain( $self, $val = undef ) {
    return $self->{domain} if @_ == 1;
    return $self->{domain} = $val;
}

sub is_valid_rf( $self, $f ) {
    return ( grep {/^\Q$f\E$/i} qw/ iodef afrf / ) ? 1 : 0;
}

sub is_valid_p( $self, $p ) {
    croak "unspecified p" if !defined $p;
    return ( grep {/^\Q$p\E$/i} qw/ none reject quarantine / ) ? 1 : 0;
}

sub is_valid_uri_list( $self, $str ) {
    $self->{uri} ||= Mail::DMARC::Report::URI->new;
    my $uris = $self->{uri}->parse($str);
    return scalar @$uris;
}

sub is_valid( $self, $obj = undef ) {
    $obj = $self                      if !$obj;
    croak "missing version specifier" if !$obj->{v};
    croak "invalid version"           if 'DMARC1' ne uc $obj->{v};

    # psd=y domains (PSDs) are not required to have a p= tag
    my $is_psd = defined $obj->{psd} && lc $obj->{psd} eq 'y';

    if ( !$obj->{p} && !$is_psd ) {
        if ( $obj->{rua} && $self->is_valid_uri_list( $obj->{rua} ) ) {
            $obj->{p} = 'none';
        }
        else {
            croak "missing policy action (p=)";
        }
    }
    if ( $obj->{p} ) {
        croak "invalid policy action" if !$self->is_valid_p( $obj->{p} );
    }
    if ( defined $obj->{np} ) {
        croak "invalid np" if !$self->is_valid_p( $obj->{np} );
    }

    # everything else is optional
    return 1;