#!/usr/bin/perl -w

use strict;
use Net::DNS; #Put in filter_initialize

my ($rv, $reason, $failtotal, $passtotal, $default_tests);

$default_tests = 1;

#RUN ME WITH EMAIL ADDRESS PARAMETERS OR I'LL RUN deFAULT TESTS
if (scalar(@ARGV) > 0) {
  while (@ARGV) {
    $ARGV = shift @ARGV;    

    if ($ARGV =~ /\@/) {
      $default_tests--;
      ($rv, $reason) = &check_valid_mx($ARGV);
      $failtotal += ($rv < 1);
      $passtotal += $rv;
    }
  }
} 

if ($default_tests > 0) {
  # TESTS I THINK SHOULD PASS
  $failtotal = 0;
  $passtotal = 0;
  
  print "\nTests Expected to Pass:\n";
  
  #Tests correct DNS - Should Pass
  ($rv, $reason) = &check_valid_mx('kevin.mcgrail@mcgrail.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  #Tests non-rfc compliant DNS using cname for MX - Should Pass
  ($rv, $reason) = &check_valid_mx('test@tri-llama.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  #Tests for implicit MX by A record - Should Pass
  ($rv, $reason) = &check_valid_mx('test@mail.mcgrail.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #Tests for something that was throwing an error in v1 where we need to discard the first answer on a CNAME domain - Should Pass
  ($rv, $reason) = &check_valid_mx('AirchieChalmers@londo.cysticercus.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  ($rv, $reason) = &check_valid_mx('OlgaCraft@barbequesauceofthemonthclub.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #Tests for use of crazy things like 12.34.56.78. as the host name in DNS - Should Pass if $allow_ip_address_as_mx = 1;
  ($rv, $reason) = &check_valid_mx('test@test.peregrinehw.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  #Tests for use of crazy things like 192.168.0.1. as the host name in DNS - Should Pass if $allow_ip_address_as_mx = 1;
  ($rv, $reason) = &check_valid_mx('test@test2.peregrinehw.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #Test for odd top level domain setups like .va for the vatican
  ($rv, $reason) = &check_valid_mx('god@va');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #Tests for a host that is configured with an MX of . but eventually has a good MX recorded (due to eNom.com (name-services.com) false positives - Should Pass
  ($rv, $reason) = &check_valid_mx('test@test6.peregrinehw.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  print "\n# of Failures for Tests Expected to Pass: $failtotal\n";
  print "# of Successes for Tests Expected to Pass: $passtotal\n";
  
  
  # TESTS I'M UNSURE SHOULD FAIL OR NOT
  
  $failtotal = 0;
  $passtotal = 0;
  
  print "\nTests I'm unsure if they should or should not Fail:\n";
  
  #RESOLVES TO AN IMPLICIT CNAME THAT IS CHAINED TO A CNAME
  ($rv, $reason) = &check_valid_mx('zacaris@muska.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  print "\n# of Failures for Uncertain Tests: $failtotal\n";
  print "# of Successes for Uncertain Tests: $passtotal\n";
  
  
  
  # TESTS THAT SHOULD FAIL
  
  $failtotal = 0;
  $passtotal = 0;
  
  print "\nTests Expected to Fail:\n";
  
  #Tests for a host that is configured with an MX of . & priority 10 which will be considered a pass due eNom.com (name-services.com) false positives - Should Fail if it's the only MX
  ($rv, $reason) = &check_valid_mx('test@test4.peregrinehw.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #Test for non-FQDN
  ($rv, $reason) = &check_valid_mx('nofrom@www');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  #Test for Explicit IP instead of domain name
  ($rv, $reason) = &check_valid_mx('postmaster@[127.0.0.1]');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #Tests for a host that is configured with an MX of . & priority 0 which is a 'I don't do email' Notification - Should Fail
  ($rv, $reason) = &check_valid_mx('test@test3.peregrinehw.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #tests for incorrect DNS
  ($rv, $reason) = &check_valid_mx('zqy152214@liyuanculture.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  ($rv, $reason) = &check_valid_mx('formation2005@carmail.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  ($rv, $reason) = &check_valid_mx('chaifai@flashmail.net');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #Test for privatized IP range use only
  ($rv, $reason) = &check_valid_mx('test@geg.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  ($rv, $reason) = &check_valid_mx('test@test5.peregrinehw.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  #Tests for non-resolvable MX records
  ($rv, $reason) = &check_valid_mx('test@tennesseen.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  ($rv, $reason) = &check_valid_mx('test@8888.com');
  $failtotal += ($rv < 1);
  $passtotal += $rv;
  
  print "\n# of Failures for Tests Expected to Fail: $failtotal\n";
  print "# of Successes for Tests Expected to Fail: $passtotal\n";
}

exit;


sub check_valid_mx {
  #Based on Idea from Les Miksell and much input from Jan Pieter Cornet
  #KAM 9-12-05 updated 10-24-05 & 11-3-05
  #takes the sender, extracts the domain name and performs multiple MX tests to see if the domain has valid
  #MX exchange records 

  my ($sender) = @_;
  my ($res, $packet, @answer, $SenderDomain, @answer2, @answer3, $rv, $reason, $i, @unsorted_answer, $debug);
  my ($check_implicit_mx, $allow_ip_address_as_mx);

  #CONSTANTS
  $debug = 1;
  $allow_ip_address_as_mx = 1;

  #FLAGS
  $check_implicit_mx = 0;


  #Setup a DNS Resolver Resource
  $res = Net::DNS::Resolver->new;

  if (defined ($res)) {
    $check_implicit_mx = 0;
    $res->defnames(0);		       #Turn off appending the default domain for names that have no dots just in case
    $res->searchlist();		       #Set the search list to undefined just in case

				       #We have also set the timeout to only 4 seconds which means we might get network delays
                                       #which we do not want to handle as an error.
    $res->tcp_timeout(4);              #Number of Seconds before query will fail
    $res->udp_timeout(4);              #Number of Seconds before query will fail

    #Strip domain name from an email address
    $SenderDomain = $sender;
    $SenderDomain =~ s/(^<|>$)//g;
    $SenderDomain =~ s/.*\@//g;

    print "\nDEBUG: Extracted Sender Domain: $SenderDomain from $sender\n" if $debug;

    #Deny Explicit IP Address Domains
    if ($SenderDomain =~ /^\[.*\]$/) {
      $reason = "Use of IP Address $SenderDomain instead of a hostname is not allowed";
      print "DEBUG: Test Failed - $reason\n" if $debug;
      return (0, $reason);  
    }

    #Perform the DNS Query - Changed to Send instead of Query method to utilize the ancount method
    $packet = $res->send($SenderDomain,'MX');

    #Net::DNS::Resolver had an error
    if (!defined $packet) {
      print "DEBUG: There was an error retrieving the MX Records for $SenderDomain\n" if $debug;
      print "DEBUG: Test Passed by Default\n" if $debug;
      return(1)
    }

    print "DEBUG: Number of Answers in the MX resolution packet is: ".$packet->header->ancount."\n" if $debug;
    #Parse the Query
    if ($packet->header->ancount > 0) {
      if (defined ($packet->answer)) {
        @answer = $packet->answer;

        for ($i = 0; $i < scalar(@answer); $i++) {
          if ($answer[$i]->type ne 'MX') {
            #DISCARD ANSWER IF THE RECORD IS NOT AN MX RECORD SUCH AS THE CNAME FOR londo.cysticercus.com
            print "DEBUG: Discarding one non-MX answer of type: ".$answer[$i]->type."\n" if $debug;
          } else {
            push @unsorted_answer, $answer[$i];
          }
        }

        undef @answer;

        print "DEBUG: Number of Answers Left to Check after discarding all but MX: ".scalar(@unsorted_answer)."\n" if $debug;
        if (scalar(@unsorted_answer) < 1) {
          $check_implicit_mx++;
        } else {
          #Sort to put answers into ascending order by mail exchange preference 
          @answer = sort {$a->preference <=> $b->preference} @unsorted_answer;
        }

        #LOOP THROUGH THE ANSWERS WE HAVE 
        for ($i = 0; $i < scalar(@answer); $i++) {
          undef $packet;
          print "DEBUG: $i - MX Answer - Type: ".$answer[$i]->type." - Exchange: ".$answer[$i]->exchange." - Length: ".length($answer[$i]->exchange)."\n" if $debug;

          #localhost isn't a valid MX so return false
          if ($answer[$i]->exchange eq 'localhost') {
            $reason = 'Invalid use of Localhost as an MX record';
            print "DEBUG: Test Failed - $reason\n" if $debug;
            return (0, $reason);
          } 

          #IF the exchange is blank and the priority is 0 and it's the last answer, let's fail 
          if ($answer[$i]->exchange eq '' && int($answer[$i]->preference) == 0 && $i == $#answer) {
            #Test if there is a Blank MX record in the first slot Per Jan-Pieter Cornet recommendation
            $reason = 'Domain is publishing a blank MX record at Priority 0';
            print "DEBUG: Test Failed - $reason\n" if $debug;
            return (0, $reason);
          }

          #resolve the exchange record
          if ($answer[$i]->exchange ne '') {
            $packet = $res->send($answer[$i]->exchange, 'A'); 
 
            if (!defined ($packet)) {
              #THERE WAS AN ERROR TRYING TO RESOLVE THE MAIL EXCHANGE
              print "DEBUG: Test Passed by Default\n" if $debug;
              return (1);
            }
            print "DEBUG: $i - Number of Answers in the MX->A resolution packet is: ".$packet->header->ancount."\n" if $debug; 
          }

          if (defined $packet && $packet->header->ancount > 0) {
            @answer2 = $packet->answer;

            print "DEBUG: $i - Resolution type of ".$answer[$i]->exchange.": ".$answer2[0]->type."\n" if $debug; 
            if ($answer2[0]->type eq "A") {
              print "DEBUG: $i - A Name Address for ".$answer[$i]->exchange.": ".$answer2[0]->address."\n" if $debug;
              ($rv, $reason) = &invalid_mx($answer2[0]->address);
              if ($rv == 1 or ($rv == 2 && $i == $#answer)) {
                print "DEBUG: Test Failed - $reason\n" if $debug; 
                return (0, $reason);
              } elsif ($rv < 1) {
                print "DEBUG: Test Passed ".$answer2[0]->address." looks good\n" if $debug;
                return (1);
              }
            } elsif ($answer2[0]->type eq "CNAME") {
              $packet = $res->send($answer2[0]->cname,'A');

              if (!defined ($packet)) {
                #THERE WAS AN ERROR TRYING TO RESOLVE THE CNAME FOR THE MAIL EXCHANGE
                print "DEBUG: Test Passed by Default\n" if $debug;
                return (1);
              }

              if ($packet->header->ancount > 0) {
                if (defined ($packet->answer)) {
                  @answer3 = $packet->answer; 
                  print "DEBUG: $i - CNAME Resolution of Type: ".$answer3[0]->type." - Address: ".$answer3[0]->address."\n" if $debug;
                  if ($answer3[0]->type eq "A") {
                    ($rv, $reason) = &invalid_mx($answer3[0]->address);
                    if ($rv == 1 or ($rv == 2 && $i == $#answer)) {
                      print "DEBUG: Test Failed - $reason\n" if $debug;
                      return (0, $reason);
                    } elsif ($rv < 1) {
                      print "DEBUG: Test Passed ".$answer3[0]->address." looks good\n" if $debug;
                      return (1);
                    }
                  } else {
                    #CNAMEs aren't RFC valid for MX's so if they chained two together, I'm not recursively resolving anymore levels, I'm just failing it
                    $reason = 'Invalid use of CNAME for primary MX record';
                    print "DEBUG: Test Failed - $reason\n" if $debug;
                    return (0, $reason);
                  }
                }
              } else {
                if ($allow_ip_address_as_mx > 0 && $answer[$i]->exchange =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
                  print "DEBUG: Test Passed - Allowing IP Address as Hostname\n" if $debug;
                  return (1);
                }

                #MX RECORD IS A CNAME WHICH DOES NOT RESOLVE
                $reason = "MX Record: ".$answer2[0]->cname." does not resolve";
                print "DEBUG: Test Failed - $reason\n" if $debug;
                return (0, $reason);
              }
            }
          } else {
            #IF THIS IS THE LAST MX RECORD AND THE EXCHANGE IS BLANK, WE FAIL IT
            if ($answer[$i]->exchange eq '') {
              if ($i == $#answer) {
                $reason = 'Domain is publishing only invalid and/or blank MX records'; 
                print "DEBUG: Test Failed - $reason\n" if $debug;
                return (0, $reason);
              }
            } else {
              #PERHAPS WE'LL ALLOW AN IP ADDRESS AS AN MX FOR MORONS WHO CONFIGURE DNS INCORRECTLY
              if ($allow_ip_address_as_mx > 0 && $answer[$i]->exchange =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
                print "DEBUG: Test Passed - Allowing IP Address as Hostname\n" if $debug;
                return (1);
              }

              #MX RECORD RETURNED DOES NOT RESOLVE
              $reason = "MX Record: ".$answer[$i]->exchange." does not resolve";
              print "DEBUG: Test Failed - $reason\n" if $debug;
              return (0, $reason);
            }
          }
        }
      }
    } else {
      ($rv, $reason) = $check_implicit_mx++;
    }

    print "DEBUG: Checking Implicit MX is set to $check_implicit_mx\n" if $debug;

    if ($check_implicit_mx > 0) {
      ($rv, $reason) = &check_implicit_mx($SenderDomain, $res, $debug);
      if (defined $rv) {
        return ($rv, $reason);
      }
    }
  } else {
    print "DEBUG: There was an error setting up a Net::DNS::Resolver resource\n" if $debug;
    print "DEBUG: Test Passed by Default\n" if $debug;
    return(1)
  }

  print "DEBUG: Test Passed\n" if $debug;
  return (1);
}

sub check_implicit_mx ($$) {
  my ($SenderDomain, $res, $debug) = @_;
 
  my ($rv, $reason, $packet, @answer, @answer2);

  print "DEBUG: Checking for Implicit MX Records\n" if $debug;
  #NO MX RECORDS RETURNED - CHECK FOR IMPLICIT MX RECORD BY A RECORD per Jan-Pieter Cornet recommendation
  $packet = $res->send($SenderDomain,'A');
  if (!defined ($packet)) {
    #THERE WAS AN ERROR - NO IMPLICIT A RECORD COULD BE RESOLVED
    print "DEBUG: Test Passed by Default\n" if $debug;
    return (1);
  }

  print "DEBUG: Number of Answers in the Implicit A record resolution packet is: ".$packet->header->ancount."\n" if $debug;
  if ($packet->header->ancount > 0) {
    @answer = $packet->answer;
    if ($answer[0]->type eq "A") {
      print "DEBUG: $SenderDomain has no MX Records - Using Implicit A Record: ".$answer[0]->address."\n" if $debug;
      ($rv, $reason) = &invalid_mx($answer[0]->address);
      if ($rv) {
        print "DEBUG: Test Failed - $reason\n" if $debug;
        return (0, $reason);
      } else {
        print "DEBUG: Test Passed ".$answer[0]->address." looks good\n" if $debug;
        return 1;
      }
    } elsif ($answer[0]->type eq "CNAME") {
      #IS THIS REALLY A NECESSARY TEST?  SHOULD WE BE TESTING FOR IMPLICIT CNAME RECORDS?
      print "DEBUG: $SenderDomain has no MX Records - Using CNAME to Check for Implicit A Record: ".$answer[0]->cname."\n" if $debug;
      $packet = $res->send($answer[0]->cname,'A');

      if (!defined ($packet)) {
        #THERE WAS AN ERROR TRYING TO RESOLVE THE CNAME FOR THE MAIL EXCHANGE
        print "DEBUG: Test Passed by Default\n" if $debug;
        return (1);
      }

      if ($packet->header->ancount > 0) {
        if (defined ($packet->answer)) {
          @answer2 = $packet->answer;
          if ($answer2[0]->type eq "A") {
             print "DEBUG: CNAME Resolution of Type: ".$answer2[0]->type." - Address: ".$answer2[0]->address."\n" if $debug;
            ($rv, $reason) = &invalid_mx($answer2[0]->address);
            if ($rv > 0) {
              print "DEBUG: Test Failed - $reason\n" if $debug;
              return (0, $reason);
            } else {
              print "DEBUG: Test Passed ".$answer2[0]->address." looks good\n" if $debug;
              return (1);
            }
          } else {
            #CNAMEs aren't RFC valid for MX's so if they chained two together, I'm not recursively resolving anymore levels, I'm just failing it
            $reason = 'Invalid use of CNAME for Implicit MX record';
            print "DEBUG: Test Failed - $reason\n" if $debug;
            return (0, $reason);
          }
        }
      }
    }
  } else {
    $reason = "No MX or A Records Exist for $SenderDomain";
    print "DEBUG: Test Failed - $reason\n" if $debug;
    return (0, $reason);
  }
  return undef;
}

sub invalid_mx {
  my ($ip, %params) = @_;
  my ($flag_intranets);

  #0/8, 255/8, 127/8 aren't a valid MX so return false - added per Matthew van Eerde recomendation
  if ($ip =~ /^(255|127|0)\./) {
    return (1, 'Invalid use of 0/8, 255/8 or 127/8 as an MX record');
  }

  $flag_intranets = 1;

  #10/8 
  if ($flag_intranets && $ip =~ /^10\./) {
    return (2, 'Invalid use of private IP range for MX');
  }
  #172.16/12 - Fixed per Matthen van Eerde
  if ($flag_intranets && $ip =~ /^172\.(16|17|18|19|20|21|22|23|24|25|26|27|28|29|30|31)\./) {
    return (2, 'Invalid use of private IP range for MX');
  }
  #192.168/16
  if ($flag_intranets && $ip =~ /^192\.168\./) {
    return (2, 'Invalid use of private IP range for MX');
  }

  #DHCP auto-discover added per Matthew van Eerde recomendation 169.254/16
  if ($ip =~ /^169\.254\./) {
    return (1, 'Invalid use of a DHCP auto-discover IP range as an MX record');
  }

  #Multicast 224/8 through 239/8 added per Matthew van Eerde recomendation
  if ($ip =~ /^(224|225|226|227|228|229|230|231|232|233|234|235|236|237|238|239)\./) {
    return (1, 'Invalid use of a Multicast IP range as an MX record');
  } 
  
  return 0;
}