checkmail.pl

   1 #! /usr/bin/perl -W
   2 #
   3 # checkmail Version 0.3 by Thomas Hochstein
   4 #
   5 # This script tries to verify the deliverability of (a) mail address(es).
   6 #
   7 # Copyright (c) 2002-2010 Thomas Hochstein <thh@inter.net>
   8 #
   9 # It can be redistributed and/or modified under the same terms under
  10 # which Perl itself is published.
  11
  12 our $VERSION = "0.3";
  13
  14 ################################# Configuration ################################
  15 # Please fill in a working configuration!
  16 my %config=(
  17             # value used for HELO/EHLO - a valid hostname you own
  18             helo => 'testhost.domain.example',
  19             # value used for MAIL FROM: - a valid address under your control
  20             from => 'mailtest@testhost.domain.example',
  21             # a syntactically valid "random" - reliably not existing - localpart
  22             rand => 'ZOq62fow1i'
  23            );
  24
  25 ################################### Modules ####################################
  26 use strict;
  27 use File::Basename;
  28 use Getopt::Std;
  29 use Net::DNS;
  30 use Net::SMTP;
  31
  32 ################################# Main program #################################
  33
  34 $Getopt::Std::STANDARD_HELP_VERSION = 1;
  35 my $myself = basename($0);
  36
  37 # read commandline options
  38 my %options;
  39 getopts('Vhqlrf:m:', \%options);
  40
  41 # -V: display version
  42 if ($options{'V'}) {
  43   print "$myself v $VERSION\nCopyright (c) 2010 Thomas Hochstein <thh\@inter.net>\n";
  44   print "This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself.\n";
  45   exit(100);
  46 };
  47
  48 # -h: feed myself to perldoc
  49 if ($options{'h'}) {
  50   exec('perldoc', $0);
  51   exit(100);
  52 };
  53
  54 # display usage information if neither -f nor an address are present
  55 if (!$options{'f'} and !$ARGV[0]) {
  56   print "Usage: $myself [-hqlr] [-m <host>] <address>|-f <file>\n";
  57   print "Options: -V  display copyright and version\n";
  58   print "         -h  show documentation\n";
  59   print "         -q  quiet (no output, just exit with 0/1/2/3)\n";
  60   print "         -l  extended logging\n";
  61   print "         -r  test random address to verify verification\n";
  62   print "  -m <host>  no DNS lookup, just test this host\n";
  63   print "  <address>  mail address to check\n\n";
  64   print "  -f <file>  parse file (one address per line)\n";
  65   exit(100);
  66 };
  67
  68 # -f: open file and read addresses to @adresses
  69 my @addresses;
  70 if ($options{'f'}) {
  71  if (-e $options{'f'}) {
  72   open FILE, "<$options{'f'}" or die("$myself ERROR: Could not open file $options{'f'} for reading: $!");
  73  } else {
  74   die("$myself ERROR: File $options{'f'} does not exist!\n");
  75  };
  76  while(<FILE>) {
  77   chomp;
  78   push(@addresses,$_);
  79  };
  80  close FILE;
  81 # fill @adresses with single address to check
  82  } else {
  83   push(@addresses,$ARGV[0]);
  84 };
  85
  86 # loop over each address and test it
  87 my (%targets,$curstat,$status,$log,$message);
  88 foreach (@addresses) {
  89   my $address = $_;
  90   (undef,my $domain) = splitaddress($address);
  91   printf("  * Testing %s ...\n",$address) if !($options{'q'});
  92   $log .=  "\n===== BEGIN $address =====\n";
  93   # get list of target hosts or take host forced via -m
  94   if (!$options{'m'}) {
  95           %targets = %{gettargets($domain,\$log)};
  96   } else {
  97     $message = sprintf("Connection to %s forced by -m.\n",$options{'m'});
  98     $log .= $message;
  99     print "    $message" if !($options{'q'});
 100     # just one target host with preference 0
 101     $targets{$options{'m'}} = 0;
 102   };
 103   if (%targets) {
 104     $curstat = checkaddress($address,\%targets,\$log);
 105   } else {
 106     $curstat = 2;
 107     $message = 'DNS lookup failure';
 108     printf("  > Address is INVALID (%s).\n",$message) if !($options{'q'});
 109     $log .= $message . '.';
 110   };
 111   $log   .=  "====== END $address ======\n";
 112   $status = $curstat if (!defined($status) or $curstat > $status);
 113 };
 114
 115 print $log if ($options{'l'});
 116
 117 # status 0: valid / batch processing
 118 #        1: connection failed or temporary failure
 119 #        2: invalid
 120 #        3: cannot verify
 121 #D print "\n-> EXIT $status\n";
 122 exit($status);
 123
 124 ################################## gettargets ##################################
 125 # get mail exchanger(s) or A record(s) for a domain
 126 # IN : $domain: domain to query the DNS for
 127 # OUT: \%targets: reference to a hash containing a list of target hosts
 128 sub gettargets {
 129   my ($domain,$logr) = @_;
 130   # resolver objekt
 131   my $resolver = Net::DNS::Resolver->new(udp_timeout => 15, tcp_timeout => 15);
 132
 133   my %targets;
 134   # get MX record(s) as a list sorted by preference
 135   if (my @mxrr = mx($resolver,$domain)) {
 136     print_dns_result($domain,'MX',scalar(@mxrr),undef,$logr);
 137     foreach my $rr (@mxrr) {
 138          $targets{$rr->exchange} = $rr->preference;
 139          $$logr .= sprintf("(%d) %s\n",$rr->preference,$rr->exchange);
 140     };
 141   # no MX record found; log and try A record(s)
 142   } else {
 143     print_dns_result($domain,'MX',undef,$resolver->errorstring,$logr);
 144     print("    Falling back to A record ...\n") if !($options{'q'});
 145         # get A record(s)
 146     if (my $query = $resolver->query($domain,'A','IN')) {
 147       print_dns_result($domain,'A',$query->header->ancount,undef,$logr);
 148       foreach my $rr ($query->answer) {
 149         $targets{$rr->address} = 0;
 150         $$logr .= sprintf("- %s\n",$rr->address);
 151       };
 152     # no A record found either; log and fail
 153     } else {
 154       print_dns_result($domain,'A',undef,$resolver->errorstring,$logr);
 155       printf("    %s has neither MX nor A records - mail cannot be delivered.\n",$domain) if !($options{'q'});
 156     };
 157   };
 158   return \%targets;
 159 };
 160
 161 ################################# checkaddress #################################
 162 # test address for deliverability
 163 # IN : $address: adress to be tested
 164 #      \%targets: reference to a hash containing a list of MX hosts
 165 #      \$log    : reference to the log (to be printed out via -l)
 166 # OUT: ---
 167 #      \$log will be changed
 168 sub checkaddress {
 169   my ($address,$targetsr,$logr) = @_;
 170   my %targets = %{$targetsr};
 171   my $status;
 172   # walk %targets in order of preference
 173   foreach my $host (sort { $targets{$a} <=> $targets{$b} } keys %targets) {
 174     printf("  / Trying %s (%s) with %s\n",$host,$targets{$host} || 'A',$address) if !($options{'q'});
 175           $$logr .= sprintf("%s:\n%s\n",$host,"-" x (length($host)+1));
 176           $status = checksmtp($address,$host,$logr);
 177           last if ($status != 1);
 178   };
 179   return $status;
 180 };
 181
 182 ################################### checksmtp ##################################
 183 # connect to a remote machine on port 25 and test deliverability of a mail
 184 # address by doing the SMTP dialog until RCPT TO stage
 185 # IN : $address: address to test
 186 #      $target : target host
 187 #      \$log    : reference to the log (to be printed out via -l)
 188 # OUT: .........: reference to a hash containing a list of target hosts
 189 #      \$log will be changed
 190 sub checksmtp {
 191   my ($address,$target,$logr) = @_;
 192   my ($status);
 193   # start SMTP connection
 194   if (my $smtp = Net::SMTP->new($target,Hello => $config{'helo'},Timeout => 30)) {
 195     $$logr .= $smtp->banner; # Net::SMTP doesn't seem to support multiline greetings.
 196     $$logr .= "EHLO $config{'helo'}\n";
 197     log_smtp_reply($logr,$smtp->code,$smtp->message);
 198     $smtp->mail($config{'from'});
 199     $$logr .= "MAIL FROM:<$config{'from'}>\n";
 200     log_smtp_reply($logr,$smtp->code,$smtp->message);
 201     # test address
 202     my ($success,$code,@message) = try_rcpt_to(\$smtp,$address,$logr);
 203     # connection failure?
 204     if ($success < 0) {
 205       $status = connection_failed();
 206     # delivery attempt was successful?
 207     } elsif ($success) {
 208       # -r: try random address (which should be guaranteed to be invalid)
 209       if ($options{'r'}) {
 210         (undef,my $domain) = splitaddress($address);
 211         my ($success,$code,@message) = try_rcpt_to(\$smtp,$config{'rand'}.'@'.$domain,$logr);
 212         # connection failure?
 213         if ($success < 0) {
 214           $status = connection_failed();
 215         # verification impossible?
 216         } elsif ($success) {
 217           $status = 3;
 218           print "  > Address verificaton impossible. You'll have to send a test mail ...\n" if !($options{'q'});
 219         }
 220       }
 221       # if -r is not set or status was not set to 3: valid address
 222       if (!defined($status)) {
 223         $status = 0;
 224         print "  > Address is valid.\n" if !($options{'q'});
 225       };
 226     # delivery attempt failed?
 227     } else {
 228       $status = 2;
 229       print "  > Address is INVALID:\n" if !($options{'q'});
 230       print '    ' . join('    ',@message) if !($options{'q'});
 231     }
 232     # terminate SMTP connection
 233     $smtp->quit;
 234     $$logr .= "QUIT\n";
 235     log_smtp_reply($logr,$smtp->code,$smtp->message);
 236   } else {
 237     # SMTP connection failed / timeout
 238     $status = connection_failed();
 239     $$logr .= "---Connection failure---\n";
 240   };
 241   return $status;
 242 }
 243
 244 ################################# splitaddress #################################
 245 # split mail address into local and domain part
 246 # IN : $address: a mail address
 247 # OUT: $local : local part
 248 #      $domain: domain part
 249 sub splitaddress {
 250   my($address)=@_;
 251   (my $lp = $address) =~ s/^([^@]+)@.*/$1/;
 252   (my $domain = $address) =~ s/[^@]+\@(\S*)$/$1/;
 253   return ($lp,$domain);
 254 };
 255
 256 ################################ parse_dns_reply ###############################
 257 # parse DNS response codes and return code and description
 258 # IN : $response: a DNS response code
 259 # OUT: "$response ($desciption)"
 260 sub parse_dns_reply {
 261   my($response)=@_;
 262   my %dnsrespcodes = (NOERROR  => 'empty response',
 263                       NXDOMAIN => 'non-existent domain',
 264                       SERVFAIL => 'DNS server failure',
 265                       REFUSED  => 'DNS query refused',
 266                       FORMERR  => 'format error',
 267                       NOTIMP   => 'not implemented');
 268   if(defined($dnsrespcodes{$response})) {
 269     return sprintf('%s (%s)',$response,$dnsrespcodes{$response});
 270   } else {
 271     return $response;
 272   };
 273 };
 274
 275 ############################### print_dns_result ###############################
 276 # print and log result of DNS query
 277 # IN : $domain: domain the DNS was queried for
 278 #      $type  : record type (MX, A, ...)
 279 #      $count : number of records found
 280 #      $error : DNS response code
 281 #      \$log : reference to the log (to be printed out via -l)
 282 # OUT: ---
 283 #      \$log will be changed
 284 sub print_dns_result {
 285   my ($domain,$type,$count,$error,$logr) = @_;
 286   if (defined($count)) {
 287     printf("    %d %s record(s) found for %s\n",$count,$type,$domain) if !($options{'q'});
 288     $$logr .= sprintf("%s DNS record(s):\n",$type);
 289   } else {
 290     printf("    No %s records found for %s: %s\n",$type,$domain,parse_dns_reply($error)) if !($options{'q'});
 291     $$logr .= sprintf("No %s records found: %s\n",$type,parse_dns_reply($error));
 292   };
 293   return;
 294 };
 295
 296 ################################## try_rcpt_to #################################
 297 # send RCPT TO and return replies
 298 # IN : \$smtp    : a reference to an SMTP object
 299 #      $recipient: a mail address
 300 #      \$log     : reference to the log (to be printed out via -l)
 301 # OUT: $success: true or false
 302 #      $code   : SMTP status code
 303 #      $message: SMTP status message
 304 #      \$log will be changed
 305 sub try_rcpt_to {
 306   my($smtpr,$recipient,$logr)=@_;
 307   $$logr .= sprintf("RCPT TO:<%s>\n",$recipient);
 308   my $success = $$smtpr->to($recipient);
 309   if ($$smtpr->code) {
 310     log_smtp_reply($logr,$$smtpr->code,$$smtpr->message);
 311   } else {
 312     $success = -1;
 313     $$logr .= "---Connection failure---\n";
 314   };
 315   return ($success,$$smtpr->code,$$smtpr->message);
 316 };
 317
 318 ################################ log_smtp_reply ################################
 319 # log result of SMTP command
 320 # IN : \$log    : reference to the log (to be printed out via -l)
 321 #      $code    : SMTP status code
 322 #      @message : SMTP status message
 323 # OUT: ---
 324 #      \$log will be changed
 325 sub log_smtp_reply {
 326   my($logr,$code,@message)=@_;
 327   $$logr .= sprintf('%s %s',$code,join('- ',@message));
 328   return;
 329 }
 330
 331 ############################## connection_failed ###############################
 332 # print failure message and return status 1
 333 # OUT: 1
 334 sub connection_failed {
 335   print "  > Connection failure.\n" if !($options{'q'});
 336   return 1;
 337 }