Complete rewrite.
[mail/checkmail.git] / 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 }
This page took 0.018767 seconds and 3 git commands to generate.