#!/usr/bin/perl -w use strict; use Net::DNS; use Net::IPv4Addr qw( :all ); use POSIX ":sys_wait_h"; use IO::File; use IO::Socket::INET; use IO::Select; use Fcntl; use IPC::Open3; use Data::Dumper; use English; use POSIX qw(:errno_h); $| = 1; my $hostname = "asteria.debian.or.at"; my $VERBOSE = 0; my $AFTER_SSL_SLEEP = 2; my $OPENSSL_TIMEOUT = 45; my $CHECK_LISTENS_TIMEOUT = 15; # 50 # done 3 times my $CHECK_TLS_TIMEOUT = 15; # 50 # done 3 times my $GET_MX_TIMEOUT = 5; my $WAIT_AFTER_QUIT = 2; $SIG{'CHLD'} = 'IGNORE'; sub parse_reply($) { my ($fh) = @_; my $code = undef; my $text = ''; while (1) { my $line = <$fh>; next unless defined $line; my ($thiscode, $thistext); if (($thiscode, $thistext) = $line =~ /^(\d\d\d)-(.*)$/s) { $thistext =~ s/\r\n/\n/; $text .= $thistext; next; } elsif (($thiscode, $thistext) = $line =~ /^(\d\d\d)\s+(.*)$/s) { $thistext =~ s/\r\n/\n/; $text .= $thistext; $code = $thiscode; last; } else { die ("Cannot parse $line\n"); }; }; return ($code, $text); } sub quit($) { my ($peer) = @_; print $peer "QUIT\r\n"; sleep ($WAIT_AFTER_QUIT); close $peer; }; sub do_ssl($) { my ($peer) = @_; my $listen = IO::Socket::INET->new( Listen => 1, Proto => 'tcp', ); my $port = $listen->sockport(); my $p_pid = fork(); unless ($p_pid) { my $socket = $listen->accept(); my $pid; my @children; $pid = fork(); push @children, $pid; unless ($pid) { close STDOUT; my $d; while (read($socket, $d, 1)) { print $peer $d; $peer->flush(); } exit(0); }; $pid = fork(); push @children, $pid; unless ($pid) { close STDOUT; my $d; while (read($peer, $d, 1)) { print $socket $d; $socket->flush(); }; exit(0); }; #while (@children) { # for (@children) { # my $child = waitpid($_,WNOHANG); # if ($child == $_) { # @children = grep { $_ != $child } @children; # }; # }; #}; exit(0); }; my($wtr, $rdr, $err); my $pid = open3($wtr, $rdr, $err, "timeout $OPENSSL_TIMEOUT openssl s_client -showcerts -connect localhost:$port"); #waitpid($p_pid,0); return ($wtr, $rdr, $err); }; sub check_listens($$$) { my ($peer_host, $port, $do_ssl) = @_; my ($result, $warning, $error) = (undef,undef,undef,undef); my $tls_text = ""; eval { while (1) { local $SIG{ALRM} = sub { die "alarm\n" }; alarm($CHECK_LISTENS_TIMEOUT); my $peer = IO::Socket::INET->new( PeerAddr => $peer_host, PeerPort => $port, Protocol => 'tcp', Timeout => 5, ) or $result = 0, $error = ("Cannot connect: $!"), last; alarm($CHECK_LISTENS_TIMEOUT); my ($wtr, $rdr, $err); if ($do_ssl) { print STDERR "Checking SSL for $peer_host ... do ssl\n" if ($VERBOSE >= 3); ($wtr, $rdr, $err) = do_ssl($peer); print STDERR "Checking SSL for $peer_host ... ssl done\n" if ($VERBOSE >= 3); sleep ($AFTER_SSL_SLEEP); } else { ($wtr, $rdr) = ($peer, $peer); }; alarm($CHECK_LISTENS_TIMEOUT); my ($code, $comment); while (my $line = readline($rdr)) { my ($thiscode, $thiscomment); if (($thiscode, $thiscomment) = $line =~ /^(\d\d\d)-(.*)$/s) { $thiscomment =~ s/\r\n/\n/; $comment .= $thiscomment; next; } elsif (($thiscode, $thiscomment) = $line =~ /^(\d\d\d)\s+(.*)$/s) { $thiscomment =~ s/\r\n/\n/; $comment .= $thiscomment; $code = $thiscode; last; } else { $tls_text .= $line; next; }; }; if (defined $code && defined $comment) { $error = "Code is $code and not 220 ($comment)" unless ($code == 220); #$error .= "'$comment' does not include SMTP magic string" unless $comment =~ /SMTP/; $result = 1 unless defined $error; quit($wtr); } else { close($wtr); }; close($rdr); last; }; alarm(0); }; if ($@) { die $@ unless $@ eq "alarm\n"; $error = "alarm - timeout"; }; if (defined $error) { $error =~ s/Operation now in progress$/Timeout/; }; return ($result, $warning, $error, $tls_text); }; sub check_tls($) { my ($peer_host) = @_; my ($result, $warning, $error, $tls_text) = (undef,undef,undef,undef,undef); print STDERR "Checking TLS for $peer_host\n" if ($VERBOSE >= 2); eval { while(1) { local $SIG{ALRM} = sub { die "alarm\n" }; alarm($CHECK_TLS_TIMEOUT); print STDERR "Checking TLS for $peer_host ... connet to port 25\n" if ($VERBOSE >= 3); my $peer = IO::Socket::INET->new( PeerAddr => $peer_host, PeerPort => 'smtp', Protocol => 'tcp', Timeout => 5, ) or $error = ("Cannot connect: $!"), last; alarm($CHECK_TLS_TIMEOUT); my ($code, $comment) = parse_reply($peer); $error = "Code is $code and not 220 ($comment)", quit($peer), last unless ($code == 220); #$error = "'$comment' does not include SMTP magic string", quit($peer), last unless $comment =~ /SMTP/; $result = 0, quit($peer), last unless $comment =~ /ESMTP/; print STDERR "Checking TLS for $peer_host ... send EHLO\n" if ($VERBOSE >= 3); print $peer "EHLO $hostname\r\n"; ($code, $comment) = parse_reply($peer); $error = "Code is $code and not 250 ($comment)", quit($peer), last unless ($code == 250); my $tls = $comment =~ m/^STARTTLS$/im ? 1 : 0; $result = 0, quit($peer), last unless $tls; print STDERR "Checking TLS for $peer_host ... send STARTTLS\n" if ($VERBOSE >= 3); $result = 1; print $peer "STARTTLS\r\n"; ($code, $comment) = parse_reply($peer); $warning = "STARTTLS return code is $code and not 220 ($comment)", quit($peer), last unless ($code == 220); alarm($CHECK_TLS_TIMEOUT); print STDERR "Checking TLS for $peer_host ... do ssl\n" if ($VERBOSE >= 3); my ($wtr, $rdr, $err) = do_ssl($peer); print STDERR "Checking TLS for $peer_host ... ssl done\n" if ($VERBOSE >= 3); sleep $AFTER_SSL_SLEEP; print STDERR "Checking TLS for $peer_host ... quit\n" if ($VERBOSE >= 3); quit($wtr); my $r = join '', <$rdr>; close $rdr; $tls_text = $r; last; }; alarm(0); }; if ($@) { die $@ unless $@ eq "alarm\n"; $error = "alarm - timeout"; }; if (defined $error) { $error =~ s/Operation now in progress$/Timeout/; }; print STDERR "Checking TLS for $peer_host ... done\n" if ($VERBOSE >= 3); return ($result, $warning, $error, $tls_text); }; sub get_mx($) { my ($domain) = @_; my @result; my @mx = mx($domain); if (scalar @mx) { @result = map { { preference => $_->preference, exchange => $_->exchange } } @mx; } else { @result = ( { preference => 0, exchange => $domain } ); }; return @result; }; sub check_mx($) { my ($host) = @_; my $error = undef; my $result = undef; my $warning = undef; my $tls = undef; my $query; my $address; my $res; eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm($GET_MX_TIMEOUT); $res = Net::DNS::Resolver->new; $query = $res->search($host); alarm(0); }; if ($@) { die $@ unless $@ eq "alarm\n"; $error = "DNS query timed out."; }; if ($query) { foreach my $rr ($query->answer) { next unless $rr->type eq "A"; if (defined $address) { $warning = "$host has round robin A records"; next; }; $address = $rr->address; } $error = "does not resolve to an ipv4 address" unless defined $address; } else { $error = "query failed: ".$res->errorstring } # 0.0.0.0 /8 Reserved # 10.0.0.0 /8 RFC 1918 Private # 14.0.0.0 /8 Public Data Network1 # 127.0.0.0 /8 Loopback # 169.254.0.0 /16 Link-local # 172.16.0.0 /12 RFC 1918 Private # 192.0.2.0 /24 Example network # 192.168.0.0 /16 RFC 1918 Private # 224.0.0.0 /4 Multicast (Class D) # 240.0.0.0 /4 Unspecified (Class >D) if (defined $address && (ipv4_in_network("0.0.0.0/8", $address) || ipv4_in_network("10.0.0.0/8", $address) || ipv4_in_network("127.0.0.1/8", $address) || ipv4_in_network("169.254.0.0/16", $address) || ipv4_in_network("172.16.0.0/12", $address) || ipv4_in_network("192.0.2.0/24", $address) || ipv4_in_network("192.168.0.0/16", $address) || ipv4_in_network("224.0.0.0/4", $address) || ipv4_in_network("240.0.0.0/4", $address))) { $error = "stupid admin sets A record to special address space ($address)" }; my $return; $return->{'smtp'} = { error => $error, warning => $warning, }; unless (defined $error) { my ($r, $w, $e, $t); print STDERR $host." tls1\n" if ($VERBOSE >= 2); ($r, $w, $e, $t) = check_tls($host); $result .= $r if defined $r; $warning .= $w if defined $w; $error .= $e if defined $e; $tls = $t if defined $t; $return->{'smtp'} = { error => $error, warning => $warning, result => $result, tls => $t }; print STDERR $host." sub\n" if ($VERBOSE >= 2); ($r, $w, $e, $t) = check_listens($host, '587', 0); $return->{'submission'} = { error => $e, warning => $w, result => $r, tls => $t }; print STDERR $host." smtps\n" if ($VERBOSE >= 2); ($r, $w, $e, $t) = check_listens($host, 'smtps', 1); $return->{'smtps'} = { error => $e, warning => $w, result => $r, tls => $t }; print STDERR $host." 2525\n" if ($VERBOSE >= 2); ($r, $w, $e, $t) = check_listens($host, '2525', 0); $return->{'2525'} = { error => $e, warning => $w, result => $r, tls => $t }; #print STDERR $host." 25000\n" if ($VERBOSE >= 2); #($r, $w, $e, $t) = check_listens($host, '25000', 0); #$return->{'25000'} = { # error => $e, # warning => $w, # result => $r, # tls => $t #}; #print STDERR $host." 22222\n" if ($VERBOSE >= 2); #($r, $w, $e, $t) = check_listens($host, '22222', 0); #$return->{'22222'} = { # error => $e, # warning => $w, # result => $r, # tls => $t #}; print STDERR $host." checkmx DONE\n" if ($VERBOSE >= 2); }; return $return; }; sub do_address($) { my ($address) = @_; my ($localpart, $domain) = split (/@/, $address); my @mx = get_mx($domain); my @result; for my $mx (@mx) { my $res = check_mx($mx->{exchange}); push @result, { mx => $mx->{exchange}, pri => $mx->{preference}, res => $res, }; }; return \@result; }; my @addresses; my %NICKS; while (<>) { # $remailer{"aarg"} = " cpunk if (/remailer\{"(\S+)"\}.*<([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+)>/) { push @addresses, $2; $NICKS{$2} = $1; } elsif (/<([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+)>/) { push @addresses, $1; }; }; my %unique; @addresses = sort { $a cmp $b } @addresses; @addresses = grep { !$unique{$_}++ } @addresses; my %FH; my @PIDs; for my $address (@addresses) { $FH{$address} = new IO::File; my $pid = $FH{$address}->open("-|"); unless (defined $pid) { die ("Could not fork: $!"); }; unless ($pid) { # child my $result = do_address($address); my $dump = Data::Dumper->Dump( [$result] ); print STDERR "printing data for $address\n" if ($VERBOSE >= 2); print $dump; print STDERR "printed: $dump\n" if ($VERBOSE >= 6); print STDERR "exiting child for $address\n" if ($VERBOSE >= 2); exit(0); }; push @PIDs, $pid; fcntl($FH{$address}, F_SETFL, O_NONBLOCK) or die "can't set non blocking: $!"; }; my $result; my $END = time + 600; my $last_notice = 0; while ($END > time) { my $s = IO::Select->new(); for my $address (@addresses) { $s->add($FH{$address}) if exists $FH{$address}; }; last if $s->count() == 0; if ($VERBOSE && $last_notice < time - 3) { print STDERR ("Still waiting for ".join(", ", grep {exists $FH{$_}} @addresses)."\n"); $last_notice = time; }; my $timeout = 3; print STDERR "Calling can_read\n" if ($VERBOSE >= 3); my @ready = $s->can_read($timeout); my $forced = 0; if (scalar @ready == 0) { print STDERR "no ready handles, read them all\n" if $VERBOSE; @ready = $s->handles(); $forced = 1; }; for my $fh (@ready) { print STDERR "$fh is ready".($forced ? " (not really)" : "")."\n" if ($VERBOSE >= 3); my $addr; for my $address (@addresses) { next unless exists $FH{$address}; if ($fh->fileno() == $FH{$address}->fileno()) { $addr = $address; last; }; }; die ("No address for $fh\n"), next unless defined $addr; print STDERR "reading fh for $addr\n" if ($VERBOSE >= 2); my $buf; my $res = sysread($fh, $buf, 100000); my $error = $ERRNO; print STDERR "$fh read $res bytes\n" if (defined $res && $VERBOSE); if (!defined $res) { printf STDERR ("got error $ERRNO, again: %d, wouldb: %d\n", EAGAIN, EWOULDBLOCK) if ($VERBOSE > 5); printf STDERR ("got error $ERRNO\n") if ($ERRNO != EWOULDBLOCK); } elsif ($res > 0) { $result->{$addr} .= $buf; } else { $fh->close; delete $FH{$addr}; print STDERR "$addr reading DONE\n" if $VERBOSE; }; }; }; print STDERR "DONE\n" if $VERBOSE; for my $address (@addresses) { if (exists $FH{$address}) { delete $result->{$address}; warn ("$address failed\n"); }; }; for my $key (keys %$result) { my $VAR1; my $fo = eval ($result->{$key}); $VAR1 = undef; $result->{$key}= $fo; }; =pod print STDERR "FOOOOO\n"; my $result; for my $address (@addresses) { eval { alarm(200); print STDERR "waiting for $address.\n" if $VERBOSE; my $fh = $FH{$address}; undef $/; my $res = <$fh>; $FH{$address}->close; my $VAR1; my $fo = eval ($res); $result->{$address} = $fo; $VAR1 = undef; print STDERR "$address READ.\n" if $VERBOSE; }; }; alarm(0); if ($@) { die $@ unless $@ eq "alarm\n"; }; =cut #my $kid; #do { # $kid = waitpid(-1,WNOHANG); #} until $kid == -1; my $data; for my $remailer (keys %$result) { my $d; $d->{'address'} = $remailer; $d->{'nick'} = $NICKS{$remailer} || 'N/A'; $d->{'mx'} = $result->{$remailer}; push @{$data}, $d; }; print Data::Dumper->Dump( [$data] );