
=head1 check_mailrule

überprüft eine MailRegel auf Gültigkeit

=head2 Argumente

=over 4

=item $quelle

gewünschte Quell-Adresse der MailRegel als String

=item $typ

gewünscher Regeltyp als Descriptor-Nummer

=item $ziel

gewünschtes Ziel der MailRegel als String

=back

=head2 Ergebnis

I<Wahr>, falls keine Fehler entdeckt wurden.
Andernfalls I<falsch>, und es wird ein L<Problem|Fehler/problem> gesetzt.

=back

=cut

use utf8;
use warnings;
no warnings "redefine";
use strict;
use Cf '$MX';
use Dbase::Globals qw(bignum find_descr get_descr get_gruppen test_gruppe);
use Dbase::Help qw(DoFn qquote);
use Email::Valid ();
use Fehler qw(problem warnung);
use Loader qw(dns_resolve);

my %mx;
++$mx{ +lc } for split ' ', $MX;

my ( $at_allowed_grs, $at_allowed_grc ) =
  get_gruppen( mailrules_ident => '@_allowed', 1 );

my ( $is_rewrite_grs, $is_rewrite_grc ) =
  get_gruppen( mailrules_ident => 'rewrite', 1 );

my ( $multiple_targets_grs, $multiple_targets_grc ) =
  get_gruppen( mailrules_ident => 'multiple_targets', 1 );

my ( $target_irrelevant_grs, $target_irrelevant_grc ) =
  get_gruppen( mailrules_ident => 'target_irrelevant', 1 );

my ( $to_domain_grs, $to_domain_grc ) =
  get_gruppen( mailrules_ident => 'to_domain', 1 );

my ( $to_host_grs, $to_host_grc ) =
  get_gruppen( mailrules_ident => 'to_host', 1 );

my ( $to_freetext_grs, $to_freetext_grc ) =
  get_gruppen( mailrules_ident => 'to_freetext', 1 );

sub check_mailrule($$$) {
	my ( $quelle, $typ, $ziel ) = @_;

	if ( defined $quelle ) {
		my ($domain) = $quelle =~ /([^@]*)$/;
		if ( $quelle =~ /\@/ ) {

			return problem( 'Bei Regeltyp '
				  . get_descr( mailrules => $typ )
				  . ' sind auf der Quellen-Seite nur Domains erlaubt.' )
			  unless test_gruppe(
				mailrules => $typ,
				$at_allowed_grs, $at_allowed_grc
			  );

			return problem("<$quelle> ist keine gültige Mail-Adresse.")
			  unless Email::Valid->new->address($quelle);

			return problem(<<'_') if $quelle =~ /^[^@]*-.*-@/;
Bindestriche in Localpart-Präfixen werden bislang nicht unterstützt,
vgl. RT#226904.
_
			if (
				my ( $_typ, $_ziel ) = DoFn(
					'SELECT typ,ziel FROM mailrules WHERE quelle = '
					  . qquote($domain)
				)
			  )
			{
				warnung(qq(Für "$domain" existiert eine )
					  . get_descr( mailrules => $_typ )
					  . qq(-Weiterleitung auf "$_ziel".) )
				  unless test_gruppe(
					mailrules => $_typ,
					$is_rewrite_grs, $is_rewrite_grc
				  );
			}
		}
		if ( '.' ne substr $domain, 0, 1 ) {
			my $answer = dns_resolve( $domain, 'MX' ) or return;
			while ( $answer->header->ancount
				&& ( my $a = ( $answer->answer )[0] )->type eq 'CNAME' )
			{
				$answer = dns_resolve( $a->cname, 'MX' ) or return;
			}
			if ( $answer->header->ancount ) {
				warnung( <<_ . $answer->string )
MX-Records für "$domain" zeigen nicht ausschließlich auf $MX:
_
				  if grep !exists $mx{ lc $_->exchange }, $answer->answer;
			}
			else {
				warnung(qq(Für "$domain" gibt es keinen MX-Record.\n));
			}
		}
	}

	unless (
		test_gruppe(
			mailrules => $typ,
			$target_irrelevant_grs, $target_irrelevant_grc
		)
	  )
	{
		return problem(<<'_') unless defined $ziel;
Eine MailRegel dieses Typs muss ein Ziel haben.
_

		return problem(<<'_') if $ziel =~ /[^ !"#%-\177]/;
MailRegel-Ziele dürfen nur druckbare ASCII- und keine Dollarzeichen enthalten,
vgl. etwa RT#168106.
_

		if (
			test_gruppe(
				mailrules => $typ,
				$multiple_targets_grs, $multiple_targets_grc
			)
		  )
		{
			my $mf = bignum(1) << find_descr( pwdomain => mail => 1 );
			for ( split /,/, $ziel ) {
				if (/\@(.*)/) {    # <user@domain>
					return problem("<$_> ist keine gültige Mail-Adresse.")
					  unless Email::Valid->new->address($_);
					my $answer;
					return problem(<<_)
Die Domain "$1" gibt es im DNS nicht; bitte erstmal dort eintragen!
_
					  unless ( $answer = dns_resolve( $1, 'MX' ) or return )
					  && $answer->header->ancount
					  || ( $answer = dns_resolve($1) or return )
					  && $answer->header->ancount;
				}
				else {             # Username
					my $u = $_;
					my ( $v, $w ) =
					  DoFn(
"SELECT id, pwuse FROM person WHERE user = ${\qquote $u}"
					  );
					return problem(qq(Es gibt keinen Benutzer namens "$u".))
					  unless $v;
					return problem(<<_) unless $w & $mf;
Bevor Du was auf den Benutzer "$_" umleitest,
verpass dem bitte erstmal ein mail-Flag!
_
				}
			}
		}
		elsif (
			!test_gruppe(
				mailrules => $typ,
				$to_freetext_grs, $to_freetext_grc
			)
			&& $ziel =~ /,/
		  )
		{
			return problem( 'Bei Regeltyp '
				  . get_descr( mailrules => $typ )
				  . ' ist nur ein Ziel erlaubt.' );
		}

		if ( test_gruppe( mailrules => $typ, $to_domain_grs, $to_domain_grc ) )
		{
			my $answer;
			return problem(<<_)
Für "$ziel" scheint's im DNS weder einen MX- noch einen A-Record zu geben;
bitte erstmal da eintragen!
_
			  unless ( $answer = dns_resolve( $ziel, 'MX' ) or return )
			  && $answer->header->ancount
			  || ( $answer = dns_resolve($ziel) or return )
			  && $answer->header->ancount;
		}

		if ( test_gruppe( mailrules => $typ, $to_host_grs, $to_host_grc ) ) {
			my $answer = dns_resolve($ziel) or return;
			return problem(<<_) unless $answer->header->ancount;
Für "$ziel" scheint's im DNS keinen A-Record zu geben;
bitte erstmal da eintragen!
_
		}
	}

	1;
}

1
