Repository: noxxi/p5-ssl-tools Branch: master Commit: f3c5c232b173 Files: 6 Total size: 66.1 KB Directory structure: gitextract_f7_tdnos/ ├── README.md ├── analyze-ssl.pl ├── check-ssl-heartbleed.pl ├── https_ocsp_bulk.pl ├── mx_starttls_bulk-summarize.pl └── mx_starttls_bulk.pl ================================================ FILE CONTENTS ================================================ ================================================ FILE: README.md ================================================ # Collection of SSL Tools This repository contains various tools, which are intended to debug or analyze problems related to SSL/TLS. ## Analyzing state of TLS - analyze-ssl.pl - check support for various SSL/TLS version - check which ciphers are support - verfiy certificate - check OCSP state - check if SNI is supported and/or required - display chain certificates and also local root if certification succeeded - support direct connection and various form of STARTTLS - ... ## SMTP TLS support (STARTTLS) - mx_starttls_bulk.pl - bulk checking of domains for SMTP TLS support - fast parallel checking with non-blocking I/O: 40..60 domains/s which includes MX lookups and several TLS connections - checks for common problems with TLS support in MTA - does not try to verify certificates, because STARTTLS itself is open to MITM attacks by stripping STARTTLS support - mx_starttls_bulk_summarize.pl - summarize data created by mx_starttls_bulk ## HTTPS: Certificate Verification, OCSP ... - https_ocsp_bulk.pl - check lots of sites for certificate verification, ciphers and OCSP revocation problems - synchronous, i.e one site gets checked after the other ## Heartbleed - check-ssl-heartbeat.pl - check for heartbleed OpenSSL vulnerability - supports various protocols requiring STARTTLS or similar ================================================ FILE: analyze-ssl.pl ================================================ #!/usr/bin/perl # # Copyright 2013..2015 Steffen Ullrich # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. use strict; use warnings; use Socket; use IO::Socket::SSL 1.984; use IO::Socket::SSL::Utils; use Getopt::Long qw(:config posix_default bundling); use Socket qw(AF_INET unpack_sockaddr_in inet_ntoa); use Data::Dumper; my ($can_ipv6,$ioclass); BEGIN { $can_ipv6 = IO::Socket::SSL->can_ipv6; if ($can_ipv6) { if (defined(&Socket::getaddrinfo) && defined(&Socket::inet_ntop) && defined(&Socket::unpack_sockaddr_in6) && defined(&Socket::AF_INET6)) { Socket->import(qw(AF_INET6 inet_ntop unpack_sockaddr_in6)); } elsif ( eval { require Socket6 }) { Socket6->import(qw(AF_INET6 inet_ntop unpack_sockaddr_in6)); } else { $can_ipv6 = undef; } } $ioclass = $can_ipv6 || 'IO::Socket::INET'; } my $can_ocsp = IO::Socket::SSL->can_ocsp; my $ocsp_cache = $can_ocsp && IO::Socket::SSL::OCSP_Cache->new; my %starttls = ( '' => [ 443,undef, 'http' ], 'smtp' => [ 25, \&smtp_starttls, 'smtp' ], 'http_proxy' => [ 443, \&http_connect,'http' ], 'http_upgrade' => [ 80, \&http_upgrade,'http' ], 'imap' => [ 143, \&imap_starttls,'imap' ], 'pop' => [ 110, \&pop_stls,'pop3' ], 'ftp' => [ 21, \&ftp_auth,'ftp' ], 'postgresql' => [ 5432, \&postgresql_init,'default' ], ); my $verbose = 0; my $timeout = 10; my ($stls,$stls_arg); my $capath; my $all_ciphers; my $all_ip = 1; my $show_chain = 1; my $dump_chain; my %conf; my $max_cipher = 'HIGH:ALL'; my $default_cipher = ''; my $sleep = 0; GetOptions( 'h|help' => sub { usage() }, 'v|verbose:1' => \$verbose, 'd|debug:1' => \$IO::Socket::SSL::DEBUG, 'T|timeout=i' => \$timeout, 'CApath=s' => \$capath, 'show-chain!' => \$show_chain, 'dump-chain' => \$dump_chain, 'all-ciphers' => \$all_ciphers, 'all-ip!' => \$all_ip, 'starttls=s' => sub { ($stls,$stls_arg) = $_[1] =~m{^(\w+)(?::(.*))?$}; usage("invalid starttls $stls") if ! $starttls{$stls||'whatever'}; }, 'cert=s' => \$conf{SSL_cert_file}, 'key=s' => \$conf{SSL_key_file}, 'name=s' => \$conf{SSL_hostname}, 'cipher=s' => \$default_cipher, 'max-cipher=s' => \$max_cipher, 'sleep=s' => \$sleep, ) or usage("bad usage"); @ARGV or usage("no hosts given"); my %default_ca = ! $capath ? () : -d $capath ? ( SSL_ca_path => $capath, SSL_ca_file => '' ) : -f $capath ? ( SSL_ca_file => $capath, SSL_ca_path => '' ) : die "no such file or dir: $capath"; my $peer_certificates = IO::Socket::SSL->can('peer_certificates') || sub {}; $conf{SSL_verifycn_name} ||= $conf{SSL_hostname} if $conf{SSL_hostname}; if ($conf{SSL_cert_file}) { $conf{SSL_key_file} ||= $conf{SSL_cert_file}; $conf{SSL_use_cert} = 1; } sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR <[0] || 443; if ( $host =~m{:|^[\d\.]+$} ) { $ip = $host; $host = undef; } push @tests, [ $host||$ip,$port,$conf{SSL_hostname}||$host,$st->[1],$st->[2] || 'default' ]; } for my $test (@tests) { my ($host,$port,$name,$stls_sub,$scheme) = @$test; my @ip; if (defined &Socket::getaddrinfo) { my ($err,@res) = Socket::getaddrinfo($host,$port); for(@res) { push @ip,_addr2ip($_->{addr},$_->{family}); } } elsif (defined &Socket6::getaddrinfo) { my @res = Socket6::getaddrinfo($host,$port); while (@res>=5) { my ($family,$addr) = (splice(@res,0,5))[0,3]; push @ip,_addr2ip($addr,$family); } } else { my $ip = Socket::inet_aton($host); push @ip, $ip if $ip; } if (!@ip) { warn "Found no IP address for $host\n"; next; } if (@ip>1) { my (%have,@ip4,@ip6); for(@ip) { if ($have{$_}++) { next; } elsif (m{:}) { push @ip6,$_ } else { push @ip4,$_ } } # Prefer IPv4 even if host preference is different @ip = (@ip4,@ip6); } VERBOSE(1,"checking host=$host(@ip) port=$port". ($stls ? " starttls=$stls":"")); my @problems; my $tcp_connect = sub { my $use_ip = shift; my $tries = 1; TRY_IP: my ($cl,$error); my %ioargs = ( PeerAddr => $use_ip || $ip[0], PeerPort => $port, Timeout => $timeout, ); for(1..$tries) { if ($stls_sub) { last if $cl = eval { $stls_sub->(\%ioargs,$stls_arg) }; $error = $@ || 'starttls error'; $cl = undef; } elsif ( $cl = $ioclass->new(%ioargs)) { last; } else { $error = "tcp connect: $!"; } } return $cl if $cl; $error ||= "unknown error"; die $error if $use_ip; # no retry # retry with next IP my $failed = shift(@ip); chomp($error); push @problems, "failed tcp connect to $failed: $error"; if (@ip) { VERBOSE(1,"$failed failed permanently '$error', trying next"); goto TRY_IP; } VERBOSE(1,"$failed failed permanently '$error', no more IP to try"); die $error."\n"; }; my @handshakes; # basic connects without verification or any TLS extensions (OCSP) # find out usable version and ciphers. Because some hosts (like cloudflare) # behave differently if SNI is used we try to use it and only fall back if # it fails. my ($version,$cipher,$good_conf); my $sni = $name; my $try_sslversion = sub { my $v = shift; my (@protocols,@err); for my $ciphers ( $default_cipher,$max_cipher ) { my $cl = &$tcp_connect; if ( _startssl($cl, %conf, SSL_version => $v, SSL_verify_mode => 0, SSL_hostname => $sni, SSL_cipher_list => $ciphers, )) { $version = $cl->get_sslversion(); $cipher = $cl->get_cipher(); if (!@protocols) { push @protocols, ($version, $cipher); } elsif ($protocols[-1] ne $cipher) { push @protocols, $cipher; } $good_conf ||= { %conf, SSL_version => $v, SSL_hostname => $sni, SSL_cipher_list => $ciphers }; VERBOSE(2,"version $v no verification, ciphers=$ciphers -> $version,$cipher"); } else { VERBOSE(2,"version $v, no verification, ciphers=$ciphers -> FAIL! $SSL_ERROR"); push @err, $SSL_ERROR if ! @err || $err[-1] ne $SSL_ERROR; } } return (\@protocols,\@err); }; my $use_version; my $best_version; TRY_PROTOCOLS: for( # most compatible handshake - should better be supported by all 'SSLv23', # version specific handshakes - some hosts fail instead of downgrading defined &Net::SSLeay::CTX_tlsv1_2_new ? ('TLSv1_2'):(), defined &Net::SSLeay::CTX_tlsv1_1_new ? ('TLSv1_1'):(), defined &Net::SSLeay::CTX_tlsv1_new ? ('TLSv1') :(), defined &Net::SSLeay::CTX_v3_new ? ('SSLv3') :(), ) { my ($protocols,$err) = $try_sslversion->($_); if (@$protocols) { $use_version ||= $_; $best_version ||= $protocols->[0]; push @handshakes, [ $_, @$protocols ]; } else { push @handshakes, [ $_,\"@$err" ]; } } if ($best_version) { VERBOSE(1,"successful connect with $best_version, cipher=$cipher, sni=" . ($sni||'')." and no other TLS extensions"); } elsif ($sni) { $sni = ''; # retry without SNI goto TRY_PROTOCOLS; } else { die "$host failed basic SSL connect: $SSL_ERROR\n"; } my $sni_status; my $need_sni; if (!$sni) { if ($version =~m{^TLS}) { VERBOSE(1,"SNI FAIL!"); push @problems, "using SNI (default)"; $sni_status = 'FAIL'; } } else { VERBOSE(1,"SNI success"); $sni_status = 'ok'; # check if it works without SNI my $cl = &$tcp_connect; my $fail; if (!_startssl($cl, %$good_conf, SSL_hostname => '', SSL_verifycn_name => $conf{SSL_hostname}||$host, SSL_verify_callback => sub { my ($ok) = @_; $fail++ if ! $ok; return 1; } )) { VERBOSE(1,"failed without SNI: $SSL_ERROR"); $sni_status = "SSL upgrade fails without SNI"; $need_sni = 1; } if ($fail) { VERBOSE(1,"certificate verify failed without SNI"); $sni_status = "certificate verify fails without SNI"; } } my $ssl_upgrade_get_chain = sub { my ($cl,%conf) = @_; my (%verify_chain,@chain,@problems,$fail); my $chain_failed; if ( _startssl($cl, %conf, SSL_verifycn_scheme => 'none', SSL_verify_callback => sub { my ($valid,$store,$str,$err,$cert,$depth) = @_; $chain_failed = 1 if ! $valid; # Since this only a temporary reference we should convert it # directly to PEM. my ($subject,$bits); $subject = Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name($cert)); if (!$depth) { my @san = $cl->peer_certificate('subjectAltNames'); for( my $i=0;$i<@san;$i++) { $san[$i] = 'DNS' if $san[$i] == 2; $san[$i] .= ":".splice(@san,$i+1,1); } $subject .= " SAN=".join(",",@san) if @san; } if (my $pkey = Net::SSLeay::X509_get_pubkey($cert)) { $bits = eval { Net::SSLeay::EVP_PKEY_bits($pkey) }; Net::SSLeay::EVP_PKEY_free($pkey); } my $pem = PEM_cert2string($cert); $verify_chain{$pem} = [ $bits||'???', $subject, join('|', grep { $_ } @{ CERT_asHash($cert)->{ocsp_uri} || []}), $pem, $depth, '-' ]; return 1; }, )) { for my $cert ( $peer_certificates->($cl) ) { my ($subject,$bits); $subject = Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name($cert)); if ( !@chain) { my @san = $cl->peer_certificate('subjectAltNames'); for( my $i=0;$i<@san;$i++) { $san[$i] = 'DNS' if $san[$i] == 2; $san[$i] .= ":".splice(@san,$i+1,1); } $subject .= " SAN=".join(",",@san) if @san; } if (my $pkey = Net::SSLeay::X509_get_pubkey($cert)) { $bits = eval { Net::SSLeay::EVP_PKEY_bits($pkey) }; Net::SSLeay::EVP_PKEY_free($pkey); } my $pem = PEM_cert2string($cert); my $vc = delete $verify_chain{$pem}; if (!$vc) { push @problems, "server sent unused chain certificate ". "'$subject'"; } push @chain,[ $bits||'???', $subject, join('|', grep { $_ } @{ CERT_asHash($cert)->{ocsp_uri} || []}), $pem, $vc ? $vc->[4] : '-', # depth $#chain+1, ], } for (sort { $a->[4] <=> $b->[4] } values %verify_chain) { push @chain,$_; } if ($chain_failed) { $fail = "validation of certificate chain failed"; } elsif (!$cl->verify_hostname($name,$scheme)) { $fail = "validation of hostname failed"; } } else { $fail = $SSL_ERROR || 'unknown handshake error'; } return (@chain ? \@chain : undef,\@problems,$fail); }; # get chain info my (@cert_chain,@cert_chain_nosni); if ($show_chain || $dump_chain) { for( [ $good_conf, \@cert_chain ], ( $need_sni || ! $good_conf->{SSL_hostname}) ? () # cloudflare has different cipher list without SNI, so don't # enforce the existing one : ([ { %$good_conf, SSL_cipher_list => $default_cipher || undef, SSL_hostname => '' }, \@cert_chain_nosni ]) ) { my ($conf,$chain) = @$_; my $cl = &$tcp_connect; my ($ch,$p) = $cl ? $ssl_upgrade_get_chain->($cl,%$conf) : (); push @problems,@$p; if ($ch) { @$chain = @$ch; } else { die "failed to connect with previously successful config: $SSL_ERROR"; } } # if same chain ignore nosni if (@cert_chain_nosni and @cert_chain_nosni == @cert_chain and ! grep { $cert_chain_nosni[$_][3] ne $cert_chain[$_][3] } (0..$#cert_chain_nosni)) { VERBOSE(2,"same certificate chain in without SNI"); @cert_chain_nosni = (); } } # check verification against given/builtin CA w/o OCSP my $verify_status; my $cl = &$tcp_connect; if ( _startssl($cl, %$good_conf, SSL_verify_mode => SSL_VERIFY_PEER, SSL_ocsp_mode => SSL_OCSP_NO_STAPLE, SSL_verifycn_scheme => 'none', %default_ca )) { %conf = ( %$good_conf, SSL_verify_mode => SSL_VERIFY_PEER, %default_ca ); if (!$cl->peer_certificate) { VERBOSE(1,"no peer certificate (anonymous authentication)"); %conf = %$good_conf; $verify_status = 'anon'; } elsif ( $cl->verify_hostname( $name,$scheme )) { VERBOSE(1,"certificate verify success"); $verify_status = 'ok'; $verify_status .= " (needs SNI)" if $sni_status =~ /fails without/; %conf = %$good_conf = ( %conf, SSL_verifycn_scheme => $scheme, SSL_verifycn_name => $name, ); } else { my @san = $cl->peer_certificate('subjectAltNames'); for( my $i=0;$i<@san;$i++) { $san[$i] = 'DNS' if $san[$i] == 2; $san[$i] .= ":".splice(@san,$i+1,1); } VERBOSE(1,"certificate verify - name does not match:". " subject=".$cl->peer_certificate('subject'). " SAN=".join(",",@san) ); $verify_status = 'name-mismatch'; %conf = %$good_conf = ( %conf, SSL_verifycn_scheme => 'none'); } } else { VERBOSE(1,"certificate verify FAIL!"); $verify_status = "FAIL: $SSL_ERROR"; push @problems, "using certificate verification (default) -> $SSL_ERROR"; } # check with OCSP stapling my $ocsp_staple; if ( $can_ocsp && $verify_status eq 'ok' ) { my $cl = &$tcp_connect; $conf{SSL_ocsp_cache} = $ocsp_cache; if ( _startssl($cl, %conf)) { if ( ${*$cl}{_SSL_ocsp_verify} ) { $ocsp_staple = 'got stapled response', } else { $ocsp_staple = 'no stapled response', } VERBOSE(1,"OCSP stapling: $ocsp_staple"); } else { $ocsp_staple = "FAIL: $SSL_ERROR"; $conf{SSL_ocsp_mode} = SSL_OCSP_NO_STAPLE; VERBOSE(1,"access with OCSP stapling FAIL!"); push @problems, "using OCSP stapling (default) -> $SSL_ERROR"; } } my $ocsp_status; if ( $can_ocsp && $verify_status eq 'ok' ) { my $cl = &$tcp_connect; $conf{SSL_ocsp_mode} |= SSL_OCSP_FULL_CHAIN; if ( ! _startssl($cl, %conf)) { die sprintf("failed with SSL_ocsp_mode=%b, even though it succeeded with default mode", $conf{SSL_ocsp_mode}); } my $ocsp_resolver = $cl->ocsp_resolver; my %todo = $ocsp_resolver->requests; while (my ($uri,$req) = each %todo) { VERBOSE(3,"need to send %d bytes OCSP request to %s",length($req),$uri); } my $errors = $ocsp_resolver->resolve_blocking(); die "resolver not finished " if ! defined $errors; if ( ! $errors ) { VERBOSE(1,"all certificates verified"); $ocsp_status = "good"; } else { VERBOSE(1,"failed to verify certicates: $errors"); $ocsp_status = "FAIL: $errors"; } if (my $soft_error = $ocsp_resolver->soft_error) { $ocsp_status .= " (soft error: $soft_error)" } } # Check if all IP return the same cipher, version and certificates my %all_ip_diff; my %cert_chain_alternatives; if ($all_ip and @ip>1) { my ($cipher,$protocol,@chain,$result); for my $ip (@ip) { my $cl = eval { $tcp_connect->($ip) }; if (!$cl) { VERBOSE(1,"failed tcp connect to IP $ip: $@"); push @problems, "failed tcp connect to IP $ip: $@"; next; } my ($ch,$p,$res) = $ssl_upgrade_get_chain->($cl,%conf); $res ||= 'success'; if (!$ch) { VERBOSE(1,"failed SSL upgrade on IP $ip"); push @problems, "failed SSL upgrade on IP $ip"; next; } if (!@chain) { # baseline $result = $res; @chain = @$ch; $cipher = $cl->get_cipher; $protocol = $cl->get_sslversion; next; } my @diff; push @diff, "result: $res vs. $result" if $res ne $result; push @diff, "cipher: ".($cl->get_cipher)." vs. $cipher" if $cipher ne $cl->get_cipher; push @diff, "protocol: ".($cl->get_sslversion)." vs. $protocol" if $protocol ne $cl->get_sslversion; if (Dumper(\@chain) ne Dumper($ch)) { my $alt = $cert_chain_alternatives{ Dumper($ch) } ||= [ $ch ]; push @$alt,$ip; my @ch0 = @chain; my @ch1 = @$ch; for(my $i=0;1;$i++) { my $ch0 = shift(@ch0); my $ch1 = shift(@ch1); last if ! $ch0 && !$ch1; if (!$ch0) { push @diff, "certificate #$i is additional - $ch1->[1]"; } elsif (!$ch1) { push @diff, "certificate #$i is missing - $ch0->[1]"; } elsif ($ch0->[3] ne $ch1->[3]) { push @diff, "certificate #$i differs"; } } } if (@diff) { VERBOSE(1,"different results for SSL upgrade on $ip than on $ip[0]"); my $alt = $all_ip_diff{ Dumper(\@diff) } ||= [ \@diff ]; push @$alt,$ip; } else { VERBOSE(1,"same results for SSL upgrade on $ip compared to $ip[0]"); } } } # check out all supported ciphers my @ciphers; { my $c = "$max_cipher:eNULL"; while ($all_ciphers || @ciphers<2 ) { my $cl = &$tcp_connect; if ( _startssl($cl, %conf, SSL_verify_mode => 0, SSL_version => $conf{SSL_version}, SSL_cipher_list => $c, )) { push @ciphers, [ $cl->get_sslversion, $cl->get_cipher ]; $c .= ":!".$ciphers[-1][1]; VERBOSE(2,"connect with version %s cipher %s", @{$ciphers[-1]}); } else { VERBOSE(3,"handshake failed with $c: $SSL_ERROR"); last; } } } # try to detect if the server accepts our cipher order by trying two # ciphers in different order my $server_cipher_order; if (@ciphers>=2) { my %used_cipher; for( "$ciphers[0][1]:$ciphers[1][1]:$max_cipher","$ciphers[1][1]:$ciphers[0][1]:$max_cipher" ) { my $cl = &$tcp_connect; if ( _startssl($cl, %conf, SSL_version => $use_version, SSL_verify_mode => 0, SSL_cipher_list => $_, )) { VERBOSE(3,"tried with cipher list '$_' -> ".$cl->get_cipher); $used_cipher{$cl->get_cipher}++; } else { warn "failed to SSL handshake with SSL_cipher_list=$_: $SSL_ERROR"; } } if (keys(%used_cipher) == 2) { VERBOSE(2,"client decides cipher order"); $server_cipher_order = 0; } elsif ( (values(%used_cipher))[0] == 2 ) { VERBOSE(2,"server decides cipher order"); $server_cipher_order = 1; } } # summary print "-- $host port $port".($stls? " starttls $stls":"")."\n"; print " ! $_\n" for(@problems); print " * maximum SSL version : $best_version ($use_version)\n"; print " * supported SSL versions with handshake used and preferred cipher(s):\n"; printf " * %-9s %-9s %s\n",qw(handshake protocols ciphers); for(@handshakes) { printf(" * %-9s %-9s %s\n", $_->[0], ref($_->[1]) ? ("FAILED: ${$_->[1]}","") : ($_->[1], join(" ",@{$_}[2..$#$_])) ); } print " * cipher order by : ".( ! defined $server_cipher_order ? "unknown\n" : $server_cipher_order ? "server\n" : "client\n" ); print " * SNI supported : $sni_status\n" if $sni_status; print " * certificate verified : $verify_status\n"; for(sort values %all_ip_diff) { my ($diff,@ip) = @$_; print " * different results on @ip\n"; print " * $_\n" for(@$diff); } if ($show_chain) { print " * chain on $ip[0]\n"; for(my $i=0;$i<@cert_chain;$i++) { my $c = $cert_chain[$i]; print " * [$c->[5]/$c->[4]] bits=$c->[0], ocsp_uri=$c->[2], $c->[1]\n" } if (@cert_chain_nosni) { print " * chain on $ip[0] without SNI\n"; for(my $i=0;$i<@cert_chain_nosni;$i++) { my $c = $cert_chain_nosni[$i]; print " * [$c->[5]/$c->[4]] bits=$c->[0], ocsp_uri=$c->[2], $c->[1]\n" } } for (sort values %cert_chain_alternatives) { my ($chain,@ip) = @$_; print " * chain on @ip\n"; for(my $i=0;$i<@$chain;$i++) { my $c = $chain->[$i]; print " * [$c->[5]/$c->[4]] bits=$c->[0], ocsp_uri=$c->[2], $c->[1]\n" } } } print " * OCSP stapling : $ocsp_staple\n" if $ocsp_staple; print " * OCSP status : $ocsp_status\n" if $ocsp_status; if ($all_ciphers) { print " * supported ciphers with $use_version handshake\n"; for(@ciphers) { printf " * %6s %s\n",@$_; } } if ($dump_chain) { print "---------------------------------------------------------------\n"; for(my $i=0;$i<@cert_chain;$i++) { my $c = $cert_chain[$i]; print "# $c->[1]\n$c->[3]\n"; } } } sub smtp_starttls { my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!"; my $last_status_line = qr/((\d)\d\d(?:\s.*)?)/; my ($line,$code) = _readlines($cl,$last_status_line); $code == 2 or die "server denies access: $line\n"; print $cl "EHLO example.com\r\n"; ($line,$code) = _readlines($cl,$last_status_line); $code == 2 or die "server did not accept EHLO: $line\n"; print $cl "STARTTLS\r\n"; ($line,$code) = _readlines($cl,$last_status_line); $code == 2 or die "server did not accept STARTTLS: $line\n"; VERBOSE(3,"...reply to starttls: $line"); return $cl; } sub imap_starttls { my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!"; <$cl>; # welcome print $cl "abc STARTTLS\r\n"; while (<$cl>) { m{^abc (OK)?} or next; $1 or die "STARTTLS failed: $_"; s{\r?\n$}{}; VERBOSE(3,"...starttls: $_"); return $cl; } die "starttls failed"; } sub pop_stls { my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!"; <$cl>; # welcome print $cl "STLS\r\n"; my $reply = <$cl>; die "STLS failed: $reply" if $reply !~m{^\+OK}; $reply =~s{\r?\n}{}; VERBOSE(3,"...stls $reply"); return $cl; } sub http_connect { my ($ioargs,$proxy) = @_; $proxy or die "no proxy host:port given"; $proxy =~m{^(?:\[(.+)\]|([^:]+)):(\w+)$} or die "invalid dst: $proxy"; my $cl = $ioclass->new( %$ioargs, PeerAddr => $1||$2, PeerPort => $3, ) or die "tcp connect: $!"; print $cl "CONNECT $ioargs->{PeerAddr}:$ioargs->{PeerPort} HTTP/1.0\r\n\r\n"; my $hdr = _readlines($cl,qr/\r?\n/); $hdr =~m{\A(HTTP/1\.[01]\s+(\d\d\d)[^\r\n]*)}; die "CONNECT failed: $1" if $2 != 200; VERBOSE(3,"...connect request: $1"); return $cl; } sub http_upgrade { my ($ioargs,$arg) = @_; my $hostname = $ioargs->{PeerAddr}; my $cl = $ioclass->new(%$ioargs) or die "tcp connect: $!"; my $rq; if ( $arg && $arg =~m{^get(?:=(\S+))?}i ) { my $path = $1 || '/'; $rq = "GET $path HTTP/1.1\r\n". "Host: $hostname\r\n". "Upgrade: TLS/1.0\r\n". "Connection: Upgrade\r\n". "\r\n"; } else { my $path = $arg && $arg =~m{^options=(\S+)}i ? $1:'*'; $rq = "OPTIONS $path HTTP/1.1\r\n". "Host: $hostname\r\n". "Upgrade: TLS/1.0\r\n". "Connection: Upgrade\r\n". "\r\n"; } print $cl $rq; my $hdr = _readlines($cl,qr/\r?\n/); $hdr =~m{\A(HTTP/1\.[01]\s+(\d\d\d)[^\r\n]*)}; die "upgrade not accepted, code=$2 (expect 101): $1" if $2 != 101; VERBOSE(3,"...tls upgrade request: $1"); return $cl; } sub ftp_auth { my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!"; my $last_status_line = qr/((\d)\d\d(?:\s.*)?)/; my ($line,$code) = _readlines($cl,$last_status_line); die "server denies access: $line\n" if $code != 2; print $cl "AUTH TLS\r\n"; ($line,$code) = _readlines($cl,$last_status_line); die "AUTH TLS denied: $line\n" if $code != 2; VERBOSE(3,"...ftp auth: $line"); return $cl; } sub postgresql_init { my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!"; # magic header to initiate SSL: # http://www.postgresql.org/docs/devel/static/protocol-message-formats.html print $cl pack("NN",8,80877103); read($cl, my $buf,1 ) or die "did not get response from postgresql"; $buf eq 'S' or die "postgresql does not support SSL (response=$buf)"; VERBOSE(3,"...postgresql supports SSL: $buf"); return $cl; } sub _readlines { my ($cl,$stoprx) = @_; my $buf = ''; while (<$cl>) { $buf .= $_; return $buf if ! $stoprx; next if ! m{\A$stoprx\Z}; return ( m{\A$stoprx\Z},$buf ); } die "eof" if $buf eq ''; die "unexpected response: $buf"; } sub _addr2ip { my ($addr,$family) = @_; if ($family == AF_INET) { (undef,$addr) = unpack_sockaddr_in($addr); return inet_ntoa($addr); } elsif (!$can_ipv6) { return (); } else { (undef,$addr) = unpack_sockaddr_in6($addr); return inet_ntop(AF_INET6(),$addr); } } sub _startssl { select(undef,undef,undef,$sleep) if $sleep; #VERBOSE(4,"start_SSL(@_)"); IO::Socket::SSL->start_SSL(@_) } sub VERBOSE { my $level = shift; $verbose>=$level || return; my $msg = shift; $msg = sprintf($msg,@_) if @_; my $prefix = $level == 1 ? '+ ' : $level == 2 ? '* ' : "<$level> "; print STDERR "$prefix$msg\n"; } ================================================ FILE: check-ssl-heartbleed.pl ================================================ #!/usr/bin/perl # Copyright: Steffen Ullrich 2014 # Public Domain: feel free to use, copy, modify without restrictions - NO WARRANTY use strict; use warnings; use Getopt::Long qw(:config posix_default bundling); # try to use IPv6 my $INETCLASS; BEGIN { my @mod = qw(IO::Socket::IP IO::Socket::INET6 IO::Socket::INET); while ($INETCLASS = shift @mod) { last if eval "require $INETCLASS"; die "failed to load $INETCLASS: $@" if ! @mod; } } my $starttls = sub {1}; my $starttls_arg; my $timeout = 5; my $quiet = 0; my $show = 0; my $show_ascii = 0; my $ssl_version = 'auto'; my @show_regex; my $heartbeats = 1; my $show_cert; my $sni_hostname; my %starttls = ( 'smtp' => [ 25, \&smtp_starttls ], 'http_proxy' => [ 8000, \&http_connect ], 'http_upgrade' => [ 80, \&http_upgrade ], 'imap' => [ 143, \&imap_starttls ], 'pop' => [ 110, \&pop_stls ], 'ftp' => [ 21, \&ftp_auth ], 'postgresql' => [ 5432, \&postgresql_init ], ); sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR < sub { usage() }, 'T|timeout=i' => \$timeout, 's|show-data:i' => sub { $show = $_[1] || 16 }, 'a|show-ascii:i' => sub { $show_ascii = $_[1] || 80 }, 'R|show-regex-match:s' => \@show_regex, 'c|show-cert' => \$show_cert, 'q|quiet' => \$quiet, 'sni-hostname:s' => \$sni_hostname, 'H|heartbeats=i' => \$heartbeats, 'starttls=s' => sub { (my $proto,$starttls_arg) = $_[1] =~m{^(\w+)(?::(.*))?$}; my $st = $proto && $starttls{$proto}; usage("invalid starttls protocol $_[1]") if ! $st; ($default_port,$starttls) = @$st; }, 'ssl_version=s' => \$ssl_version, ); # use Net::SSLeay to print certificate information # need version >= 1.46 for d2i_x509_bio my $load_netssleay = sub { return 1 if eval { require Net::SSLeay } && $Net::SSLeay::VERSION >= 1.46; return if shift; # try w/o error die "need Net::SSLeay >= 1.46 to show certificate information"; }; $load_netssleay->(0) if $show_cert; # try to do show_cert by default if not quiet, but don't complain if we # cannot do it because we have no Net::SSLeay $show_cert ||= ! $quiet && $load_netssleay->(1) && -1; $ssl_version = lc($ssl_version) eq 'ssl3' ? 0x0300 : $ssl_version =~ m{^tlsv?1(?:_([12]))?}i ? 0x0301 + ($1||0) : 0; # try possible versions my $show_regex; if (@show_regex) { my @rx; push @rx, eval { qr{$_} } || die "invalid perl regex '$_'" for(@show_regex); $show_regex = join('|',@rx); $show_regex = eval { qr{$show_regex} } || die "invalid regex: $show_regex"; } my $dst = shift(@ARGV) or usage("no destination given"); $dst .= ":$default_port" if $dst !~ m{^([^:]+|.+\]):\w+$}; ( my $hostname = $dst ) =~s{:\w+$}{}; $hostname = $1 if $hostname =~m{^\[(.*)\]$}; if ( ! defined $sni_hostname ) { $sni_hostname = $hostname; $sni_hostname = '' if $sni_hostname =~m{:|^[\d\.]+$}; # IP6/IP4 } my $connect = sub { my ($ssl_version,$sni,$ciphers) = @_; my $cl = $INETCLASS->new( ref($dst) ? ( PeerAddr => $dst->[0], PeerPort => $dst->[1] ) : ( PeerAddr => $dst ), Timeout => $timeout ) or die "failed to connect: $!"; # save dst to not resolve name every connect attempt $dst = [ $cl->peerhost, $cl->peerport ] if ! ref($dst); # disable NAGLE to send heartbeat with multiple small packets setsockopt($cl,6,1,pack("l",1)); # skip plaintext before starting SSL handshake $starttls->($cl,$hostname); # extensions my $ext = ''; if ( defined $sni and $sni ne '' ) { $ext .= pack('nn/a*', 0x00, # server_name extension + length pack('n/a*', # server_name list length pack('Cn/a*',0,$sni) # type host_name(0) + length/server_name )); } # built and send ssl client hello my $hello_data = pack("nNn14Cn/a*C/a*n/a*", $ssl_version, time(), ( map { rand(0x10000) } (1..14)), 0, # session-id length pack("C*",@$ciphers), "\0", # compression null $ext, ); $hello_data = substr(pack("N/a*",$hello_data),1); # 3byte length print $cl pack( "Cnn/a*",0x16,$ssl_version, # type handshake, version, length pack("Ca*",1,$hello_data), # type client hello, data ); my $use_version; my $got_server_hello; my $err; while (1) { my ($type,$ver,@msg) = _readframe($cl,\$err) or return; # first message must be server hello $got_server_hello ||= $type == 22 and grep { $_->[0] == 2 } @msg; return if ! $got_server_hello; # wait for server hello done if ( $type == 22 and grep { $_->[0] == 0x0e } @msg ) { # server hello done $use_version = $ver; last; } } return ($cl,$use_version); }; # these are the ciphers we try # that's all openssl -V ciphers reports with my openssl1.0.1 my @ssl3_ciphers = ( 0xC0,0x14, 0xC0,0x0A, 0xC0,0x22, 0xC0,0x21, 0x00,0x39, 0x00,0x38, 0x00,0x88, 0x00,0x87, 0xC0,0x0F, 0xC0,0x05, 0x00,0x35, 0x00,0x84, 0x00,0x8D, 0xC0,0x12, 0xC0,0x08, 0xC0,0x1C, 0xC0,0x1B, 0x00,0x16, 0x00,0x13, 0xC0,0x0D, 0xC0,0x03, 0x00,0x0A, 0x00,0x8B, 0xC0,0x13, 0xC0,0x09, 0xC0,0x1F, 0xC0,0x1E, 0x00,0x33, 0x00,0x32, 0x00,0x9A, 0x00,0x99, 0x00,0x45, 0x00,0x44, 0xC0,0x0E, 0xC0,0x04, 0x00,0x2F, 0x00,0x96, 0x00,0x41, 0x00,0x8C, 0xC0,0x11, 0xC0,0x07, 0xC0,0x0C, 0xC0,0x02, 0x00,0x05, 0x00,0x04, 0x00,0x8A, 0x00,0x15, 0x00,0x12, 0x00,0x09, 0x00,0x14, 0x00,0x11, 0x00,0x08, 0x00,0x06, 0x00,0x03, ); my @tls12_ciphers = ( 0xC0,0x30, 0xC0,0x2C, 0xC0,0x28, 0xC0,0x24, 0x00,0xA3, 0x00,0x9F, 0x00,0x6B, 0x00,0x6A, 0xC0,0x32, 0xC0,0x2E, 0xC0,0x2A, 0xC0,0x26, 0x00,0x9D, 0x00,0x3D, 0xC0,0x2F, 0xC0,0x2B, 0xC0,0x27, 0xC0,0x23, 0x00,0xA2, 0x00,0x9E, 0x00,0x67, 0x00,0x40, 0xC0,0x31, 0xC0,0x2D, 0xC0,0x29, 0xC0,0x25, 0x00,0x9C, 0x00,0x3C, ); # try to connect and do ssl handshake either with the specified version or with # different versions (downgrade). Some servers just close if you start with # TLSv1.2 instead of replying with a lesser version my ($cl,$use_version); for my $ver ( $ssl_version ? $ssl_version : ( 0x303, 0x302, 0x301, 0x300 )) { my @ciphers = (( $ver == 0x303 ? @tls12_ciphers : ()), @ssl3_ciphers ); if ( $sni_hostname ) { verbose("...try to connect with version 0x%x with SNI",$ver); ($cl,$use_version) = $connect->( $ver, $sni_hostname, \@ciphers ) and last; } verbose("...try to connect with version 0x%x w/o SNI",$ver); ($cl,$use_version) = $connect->( $ver, $sni_hostname, \@ciphers ) and last; } # TODO: if everything fails we might have a F5 in front which cannot deal # with large client hellos. die "Failed to make a successful TLS handshake with peer.\n". "Either peer does not talk SSL or sits behind some stupid SSL middlebox." if ! $cl; # heartbeat request with wrong size # send in two packets to work around stupid IDS which try # to detect attack by matching packets only my $hb = pack("Cnn/a*",0x18,$use_version, pack("Cn",1,0x4000)); for (1..$heartbeats) { verbose("...send heartbeat#$_"); print $cl substr($hb,0,1); print $cl substr($hb,1); } my $err; if ( my ($type,$ver,$buf) = _readframe($cl,\$err,1)) { if ( $type == 21 ) { verbose("received alert (probably not vulnerable)"); } elsif ( $type != 24 ) { verbose("unexpected reply type $type"); } elsif ( length($buf)>3 ) { verbose("BAD! got ".length($buf)." bytes back instead of 3 (vulnerable)"); show_data($buf,$show) if $show; show_ascii($buf,$show_ascii) if $show_ascii; if ( $show_regex ) { while ( $buf =~m{($show_regex)}g ) { print STDERR $1."\n"; } } exit 1; } else { verbose("GOOD proper heartbeat reply (not vulnerable)"); } } else { verbose("no reply($err) - probably not vulnerable"); } sub _readframe { my ($cl,$rerr,$errok) = @_; my $len = 5; my $buf = ''; vec( my $rin = '',fileno($cl),1 ) = 1; while ( length($buf)<$len ) { if ( ! select( my $rout = $rin,undef,undef,$timeout )) { $$rerr = 'timeout'; last if $errok; return; }; if ( ! sysread($cl,$buf,$len-length($buf),length($buf))) { $$rerr = "eof"; $$rerr .= " after ".length($buf)." bytes" if $buf ne ''; last if $errok; return; } $len = unpack("x3n",$buf) + 5 if length($buf) == 5; } return if length($buf)<5; (my $type, my $ver) = unpack("Cnn",substr($buf,0,5,'')); my @msg; if ( $type == 22 ) { while ( length($buf)>=4 ) { my ($ht,$len) = unpack("Ca3",substr($buf,0,4,'')); $len = unpack("N","\0$len"); push @msg,[ $ht,substr($buf,0,$len,'') ]; verbose("...ssl received type=%d ver=0x%x ht=0x%x size=%d", $type,$ver,$ht,length($msg[-1][1])); if ( $show_cert && $ht == 11 ) { my $clen = unpack("N","\0".substr($msg[-1][1],0,3)); my $certs = substr($msg[-1][1],3,$clen); my $i = 0; while ($certs ne '') { my $clen = unpack("N","\0".substr($certs,0,3,'')); my $cert = substr($certs,0,$clen,''); length($cert) == $clen or die "invalid certificate length ($clen vs. ".length($cert).")"; if ( my $line = eval { cert2line($cert) } ) { printf "[%d] %s\n",$i, $line; } elsif ( $show_cert>0 ) { die "failed to convert cert to string: $@"; } $i++; } } } } else { @msg = $buf; verbose("...ssl received type=%d ver=%x size=%d", $type,$ver,length($buf)); } return ($type,$ver,@msg); } sub smtp_starttls { my $cl = shift; my $last_status_line = qr/((\d)\d\d(?:\s.*)?)/; my ($line,$code) = _readlines($cl,$last_status_line); $code == 2 or die "server denies access: $line\n"; print $cl "EHLO example.com\r\n"; ($line,$code) = _readlines($cl,$last_status_line); $code == 2 or die "server did not accept EHLO: $line\n"; print $cl "STARTTLS\r\n"; ($line,$code) = _readlines($cl,$last_status_line); $code == 2 or die "server did not accept STARTTLS: $line\n"; verbose("...reply to starttls: $line"); return 1; } sub imap_starttls { my $cl = shift; <$cl>; # welcome print $cl "abc STARTTLS\r\n"; while (<$cl>) { m{^abc (OK)?} or next; $1 or die "STARTTLS failed: $_"; s{\r?\n$}{}; verbose("...starttls: $_"); return 1; } die "starttls failed"; } sub pop_stls { my $cl = shift; <$cl>; # welcome print $cl "STLS\r\n"; my $reply = <$cl>; die "STLS failed: $reply" if $reply !~m{^\+OK}; $reply =~s{\r?\n}{}; verbose("...stls $reply"); return 1; } sub http_connect { my $cl = shift; $starttls_arg or die "no target host:port given"; print $cl "CONNECT $starttls_arg HTTP/1.0\r\n\r\n"; my $hdr = _readlines($cl,qr/\r?\n/); $hdr =~m{\A(HTTP/1\.[01]\s+(\d\d\d)[^\r\n]*)}; die "CONNECT failed: $1" if $2 != 200; verbose("...connect request: $1"); return 1; } sub http_upgrade { my ($cl,$hostname) = @_; my $rq; if ( $starttls_arg && $starttls_arg =~m{^get(?:=(\S+))?}i ) { my $path = $1 || '/'; $rq = "GET $path HTTP/1.1\r\n". "Host: $hostname\r\n". "Upgrade: TLS/1.0\r\n". "Connection: Upgrade\r\n". "\r\n"; } else { my $path = $starttls_arg && $starttls_arg =~m{^options=(\S+)}i ? $1:'*'; $rq = "OPTIONS $path HTTP/1.1\r\n". "Host: $hostname\r\n". "Upgrade: TLS/1.0\r\n". "Connection: Upgrade\r\n". "\r\n"; } print $cl $rq; my $hdr = _readlines($cl,qr/\r?\n/); $hdr =~m{\A(HTTP/1\.[01]\s+(\d\d\d)[^\r\n]*)}; die "upgrade not accepted, code=$2 (expect 101): $1" if $2 != 101; verbose("...tls upgrade request: $1"); return 1; } sub ftp_auth { my $cl = shift; my $last_status_line = qr/((\d)\d\d(?:\s.*)?)/; my ($line,$code) = _readlines($cl,$last_status_line); die "server denies access: $line\n" if $code != 2; print $cl "AUTH TLS\r\n"; ($line,$code) = _readlines($cl,$last_status_line); die "AUTH TLS denied: $line\n" if $code != 2; verbose("...ftp auth: $line"); return 1; } sub postgresql_init { my $cl = shift; # magic header to initiate SSL: # http://www.postgresql.org/docs/devel/static/protocol-message-formats.html print $cl pack("NN",8,80877103); read($cl, my $buf,1 ) or die "did not get response from postgresql"; $buf eq 'S' or die "postgresql does not support SSL (response=$buf)"; verbose("...postgresql supports SSL: $buf"); return 1; } sub verbose { return if $quiet; my $msg = shift; $msg = sprintf($msg,@_) if @_; print STDERR $msg,"\n"; } sub show_data { my ($data,$len) = @_; my $lastd = ''; my $repeat = 0; while ( $data ne '' ) { my $d = substr($data,0,$len,'' ); $repeat++,next if $d eq $lastd; $lastd = $d; if ( $repeat ) { print STDERR "... repeated $repeat times ...\n"; $repeat = 0; } ( my $h = unpack("H*",$d)) =~s{(..)}{$1 }g; ( my $c = $d ) =~s{[\x00-\x20\x7f-\xff]}{.}g; my $hl = $len*3; printf STDERR "%-${hl}s %-${len}s\n",$h,$c; } print STDERR "... repeated $repeat times ...\n" if $repeat; } sub show_ascii { my ($data,$len) = @_; my $lastd = ''; my $repeat = 0; while ( $data ne '' ) { my $d = substr($data,0,$len,'' ); $repeat++,next if $d eq $lastd; $lastd = $d; if ( $repeat ) { print STDERR "... repeated $repeat times ...\n"; $repeat = 0; } ( my $c = $d ) =~s{[\x00-\x20\x7f-\xff]}{.}g; printf STDERR "%-${len}s\n",$c; } print STDERR "... repeated $repeat times ...\n" if $repeat; } sub cert2line { my $der = shift; my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem()); Net::SSLeay::BIO_write($bio,$der); my $cert = Net::SSLeay::d2i_X509_bio($bio); Net::SSLeay::BIO_free($bio); $cert or die "cannot parse certificate: ". Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()); my $not_before = Net::SSLeay::X509_get_notBefore($cert); my $not_after = Net::SSLeay::X509_get_notAfter($cert); $_ = Net::SSLeay::P_ASN1_TIME_put2string($_) for($not_before,$not_after); my $subject = Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name($cert)); return "$subject | $not_before - $not_after"; } sub _readlines { my ($cl,$stoprx) = @_; my $buf = ''; while (<$cl>) { $buf .= $_; return $buf if ! $stoprx; next if ! m{\A$stoprx\Z}; return ( m{\A$stoprx\Z},$buf ); } die "eof" if $buf eq ''; die "unexpected response: $buf"; } ================================================ FILE: https_ocsp_bulk.pl ================================================ #!/usr/bin/perl # Copyright 2014 Steffen Ullrich # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # checks lots of https sites for OCSP problems # USAGE: https_ocsp_bulk < list-of-sites.txt use strict; use warnings; use IO::Socket::SSL 1.984; use IO::Socket::SSL::Utils; # use a common OCSP cache for all my $ocsp_cache = IO::Socket::SSL::OCSP_Cache->new(1000); # load sites from file/stdin # for top alexa sites see http://s3.amazonaws.com/alexa-static/top-1m.csv.zip while ( my $dst = <>) { # the domain can be somewhere on the line $dst = $dst =~m{\b([\w\-]+(\.[\w\-]+)+)\b} && $1 || do { warn "SKIP: no domain found in line: $dst"; next; }; # if the name is google.com try first www.google.com and if this # fails google.com my @dst = ($dst); unshift @dst,"www.$dst" if $dst !~m{^www\.}; my $cl; while (@dst && !$cl) { $dst = shift(@dst); $cl = IO::Socket::INET->new( PeerHost => $dst, PeerPort => 443, Timeout => 5 ); } if (!$cl) { warn "SKIP: no connect to $dst\n"; next; } warn "DEBUG: trying SSL upgrade on $dst\n"; if ( IO::Socket::SSL->start_SSL($cl, SSL_hostname => $dst, SSL_verifycn_scheme => 'none', # will check later SSL_ocsp_mode => SSL_OCSP_FULL_CHAIN, SSL_ocsp_cache => $ocsp_cache, )) { my $result = $cl->get_sslversion."/".$cl->get_cipher; my $cert = $cl->peer_certificate; if (my $pkey = Net::SSLeay::X509_get_pubkey($cert)) { my $bits = eval { Net::SSLeay::EVP_PKEY_bits($pkey) }; $result .= "/$bits" if $bits; Net::SSLeay::EVP_PKEY_free($pkey); } $result .= " (ocsp:stapled)" if ${*$cl}{_SSL_ocsp_verify}; my $status; if ( IO::Socket::SSL::verify_hostname_of_cert($dst,$cert,'www')) { $status = 'ok'; } else { $status = 'badname'; $result .= " (cn:".CERT_asHash($cert)->{subject}{commonName}.")"; } my $r = $cl->ocsp_resolver; my %q = $r->requests; warn "DEBUG: $dst need ".keys(%q)." OCSP requests" ." chain_size=".(0+$cl->peer_certificates) ." URI=". join(",",keys %q)."\n" if %q; if (my $err = $r->resolve_blocking(timeout => 5)) { $status = 'badocsp'; $result .= " (ocsp_err:$err)" } if ( my $s = $r->soft_error ) { $result .= " (ocsp_softerr: $s)"; } warn "RESULT($dst) ssl-$status $result\n"; } else { warn "RESULT($dst) nossl ".($SSL_ERROR||$!)."\n"; } } ================================================ FILE: mx_starttls_bulk-summarize.pl ================================================ #!/usr/bin/perl # Copyright 2014 Steffen Ullrich # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Usage: program < output_from_mx_starttls_bulk use strict; use warnings; my %stat; while (<>) { chop; my ($dom,$result,$info) = split(' ',$_,3); my @info = $info ? $info =~m{([+-]tls:.*?)(?=$|;[+-]tls:)}g :(); $stat{total}++; if (!@info) { $stat{'notls.total'}++; if ($result =~m{^-nomx}) { $stat{'total.nomx'}++ } elsif ($result =~m{^-no-starttls}) { $stat{'total.no-starttls'}++ } else { $stat{'total.notls'}++ } } else { $stat{'total.tls'}++; if ($result =~m{^-(?!tls)}) { for(@info) { m{^\+(.*)} or next; $result = $1; last; } } if ( my ($hv,$v,$c) = $result =~m{^tls:([^\s:]+):([^/]+)/([^/]+)}) { if ($hv eq 'SSLv23') { $stat{'tls.initial'}++; } else { $stat{'tls.downgrade'}++; } $stat{"tls.$v"}++; $stat{"tls.$c"}++; $stat{"tls.$1"}++ if $c =~m{^((EC)?DHE)-}; $stat{"tls.$1"}++ if $c =~m{(RC4)-}; } elsif ( $result =~m{^-tls}) { $stat{'tls.fail'}++; } for(@info) { $stat{"tls.fail.$1"}++ if m{^-tls:([\w\-]+)}; } } } print process(); sub process { my $total = $stat{total}; my $tls_total = $stat{'total.tls'}; my $percent = sub { my ($v,$t) = @_; return '-' if !$t; return 0 if !$v; my $p = 100*$v/$t; my $f = 10 ** (2-int(log($p)/log(10))); return int($p*$f+0.5)/$f; }; for( keys %stat) { if (m{^total\.}) { $stat{"$_.percent"} = $percent->($stat{$_},$total); } elsif (m{^tls\.}) { $stat{"$_.percent"} = $percent->($stat{$_},$tls_total); } } my $t = template(); $t =~s{%{(?:([\w\.]+):)?([\w\-\.]+)}}{ sprintf( $1?"%".$1:"%s",$stat{$2}||0) }esg; $t; } sub template { return <<'TEMPLATE'; } Total domains: %{total} No MX record: %{10d:total.nomx} (%{total.nomx.percent}%) No STARTTLS: %{10d:total.no-starttls} (%{total.no-starttls.percent}%) TLS available: %{10d:total.tls} (%{total.tls.percent}%) --- TLS analysis (relativ to TLS domains) --- TLS initial success: %{10d:tls.initial} (%{tls.initial.percent}%) TLS after downgrade: %{10d:tls.downgrade} (%{tls.downgrade.percent}%) TLS total fail: %{10d:tls.fail} (%{tls.fail.percent}%) TLS common problems: TLS1.1+ required: %{10d:tls.fail.notls10} (%{tls.fail.notls10.percent}%) Only TLS1.2 ciphers: %{10d:tls.fail.no-v3-ciphers} (%{tls.fail.no-v3-ciphers.percent}%) Croak on MD5 client cert: %{10d:tls.fail.croak-md5-client-cert} (%{tls.fail.croak-md5-client-cert.percent}%) TLS protocols used: TLS1.2: %{10d:tls.TLSv1_2} (%{tls.TLSv1_2.percent}%) TLS1.1: %{10d:tls.TLSv1_1} (%{tls.TLSv1_1.percent}%) TLS1.0: %{10d:tls.TLSv1} (%{tls.TLSv1.percent}%) SSL3.0: %{10d:tls.SSLv3} (%{tls.SSLv3.percent}%) Ciphers used: ECDHE-* (PFS) %{10d:tls.ECDHE} (%{tls.ECDHE.percent}%) DHE-* (PFS) %{10d:tls.DHE} (%{tls.DHE.percent}%) RC4 (bad) %{10d:tls.RC4} (%{tls.RC4.percent}%) TEMPLATE ================================================ FILE: mx_starttls_bulk.pl ================================================ #!/usr/bin/perl # Copyright 2014 Steffen Ullrich # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # bulk check for SMTP support and problems # See -h|--help option for usage use strict; use warnings; use Net::DNS; use IO::Socket::SSL 1.967; use IO::Socket::SSL::Utils; use Data::Dumper; use Sys::Hostname; use Time::HiRes 'gettimeofday'; use Getopt::Long qw(:config posix_default bundling); use Socket; $|=1; my $DEBUG = 0; my $max_task = 500; my $timeout = 30; my $ciphers = 'DEFAULT'; my $ehlo_domain = hostname() || 'no.such.name.local'; my $ismx = 0; # multi-line SMTP response, first number of status code in $1 my $smtp_resp = qr{\A(?:\d\d\d-.*\r?\n)*(\d)\d\d .*\r?\n}; my $usage = sub { print STDERR "ERROR: @_\n" if @_; print STDERR <<"USAGE"; Bulk analysis of SMTP STARTTLS behavior. Needs TLS1.2 support in Net::SSLeay/OpenSSL. Usage: $0 [-d|--debug] [-h|--help] [--max-task N] [--hostname N] [domains] -d|--debug enable debugging -h|--help this help --max-task N maximum number of parallel analysis tasks ($max_task) --hostname N hostname used in EHLO ($ehlo_domain) --ciphers C use OpenSSL cipher string instead of 'DEFAULT' --ismx List of domains is list of MX for domains, i.e. no more MX lookup needed domains List of domains, will read lines from STDIN if not given The result will contain a line for each given domain with multiple entries separated by space. The first item will be the domain name. If the second items starts with '-' it will indicate a failure, like: -nomx No MX for domain found in DNS. -nomxip No IP for MX found in DNS. -timeout:... Timeout of task. -smtp-greeting-.. Problem during SMTP greeting. -smtp-ehlo-... Problem during SMTP EHLO command. -smtp-starttls-... Problem during SMTP STARTTLS command. -smtp-no-starttls No STARTTLS support. -tls TLS handshake finally failed. Otherwise the second item will indicate the SSL success information like this: tls:SSLv23:TLSv1/DHE-RSA-AES256-SHA | | | | | +- cipher used for connection | +---------- protocol version used for connection +----------------- handshake tried The following handshakes will be tried in this order until connection success: SSLv23 - most compatible handshake TLSv1_2 - TLS 1.2 handshake TLSv1_1 - TLS 1.1 handshake TLSv1 - TLS 1.0 handshake SSLv3 - SSL 3.0 handshake SSLv23/ALL - like SSLv23, but offers ALL ciphers (including LOW and ADH) instead of only DEFAULT The next items give information about handshakes tried and they succeeded(+tls:...) or failed(-tls:...), e.g. +tls:SSLv23:TLSv1/DHE-RSA-AES256-SHA -tls:notls10:SSL connect attempt failed...wrong version number In addition to the handshakes given above the following handshakes will be tried notls10 - SSLv23 handshake allowing up to TLS1.0. This will only be tried if TLS1.1+ is available. Failure indicate problems for TLS1.0 clients. no-v3-ciphers - SSLv23 but with explicitly disabling SSL3.0 ciphers. Failure indicate broken client, which might tried to work around POODLE related problems by disabling SSL3.0 ciphers (which are needed for TLS1.0 and TLS1.1 too) instead or additionally to disabling SSL3.0 protocol version only. This will only be tried if TLS1.2 is available. croak-md5-client-cert - SSLv23 with MD5 client certificates. This might trigger a bug in some mail servers which close TLS1.2 connection when they get a MD5 client certificate. Will only be run if TLS1.2 is available. USAGE }; GetOptions( 'h|help' => sub { $usage->() }, 'd|debug' => \$DEBUG, 'max-task=i' => \$max_task, 'hostname=s' => \$ehlo_domain, 'ciphers=s' => \$ciphers, 'ismx' => \$ismx, ) or $usage->(); $usage->("no TLS1.2 support in your Net::SSLeay/OpenSSL") if ! defined &Net::SSLeay::CTX_tlsv1_2_new; my $initial = $ismx ? [ 'A', \&dns_name2a ]:[ 'MX', \&dns_mx ]; my $next_domain = @ARGV ? sub { shift @ARGV } : sub { while (1) { defined(my $line = ) or return; return $1 if $line =~m{^([\w\.\-]+)}; } }; # What kind of tests we do: [ id,\&run_if_true,%nondefault_ssl_opt ] my @ssl_tests; # Start with SSLv23 as the most compatible, then try with downgrades for( qw(SSLv23 TLSv1_2 TLSv1_1 TLSv1), defined(&Net::SSLeay::CTX_v3_new) ? ('SSLv3'):() ) { push @ssl_tests, [ $_, # run only if no success yet sub { ! shift->{ssl_success} }, SSL_version => $_ ] } # If nothing helps try with all ciphers instead of DEFAULT. push @ssl_tests, [ 'SSLv23/ALL', sub { ! shift->{ssl_success} }, SSL_cipher_list => 'ALL' ]; # Now add some test for some typical problems: # Wrong POODLE fix by disabling all SSLv3 ciphers. Only relevant if we managed # to do a TLS1.2 handshake. push @ssl_tests, [ 'no-v3-ciphers', sub { my $succ = shift->{ssl_success} or return; return $succ->{version} eq 'TLSv1_2'; }, SSL_cipher_list => "$ciphers:!TLSv1.2" ]; # Missing support for TLS1.0 clients. Only relevant if we managed to do a # handshake with TLS1.1+. push @ssl_tests, [ 'notls10', sub { my $succ = shift->{ssl_success} or return; return $succ->{version} =~ /TLSv1_[12]/; }, SSL_version => 'SSLv23:!TLSv1_2:!TLSv1_1' ]; # *.mail.protection.outlook.com, AntiSpamProxy... # croak on MD5 client certificate used with TLS1.2 # Do this test only if handshake succeeded with TLS1.2 { my $md5cert = create_client_cert('md5',$ehlo_domain); push @ssl_tests, [ 'croak-md5-client-cert', sub { my $succ = shift->{ssl_success} or return; return $succ->{version} eq 'TLSv1_2'; }, SSL_cert => $md5cert->{cert}, SSL_key => $md5cert->{key}, ], } my $res = Net::DNS::Resolver->new; my (@task,@defer_task); my $end; my $done = 0; while (@task or !$end) { # expire old tasks my $now = time(); while (@task && $task[0]{expire} <= $now) { print "$task[0]{domain} -timeout:$task[0]{state}\n"; # failed $done++; shift @task; } while (@defer_task && @task<$max_task) { my $t = shift(@defer_task); if ($t->{resume}($t)) { delete $t->{resume}; push @task,$t; } else { $max_task--; warn "reduce max_task to $max_task\n"; $max_task<2 or die "to few parallel tasks!"; push @defer_task,$t; } } # read new tasks from stdin while (@task<$max_task and !$end) { my $dom = &$next_domain or do { $end = 1; last; }; push @task,{ domain => $dom, expire => time() + $timeout, wantread => $initial->[1], state => 'dns', ssl_tests => [ @ssl_tests ], }; DEBUG($task[-1],"new task"); $task[-1]{fd} = $res->bgsend($dom,$initial->[0]) or do { push @defer_task,pop(@task); $defer_task[-1]{resume} = sub { my $task = shift; $task->{fd} = $res->bgsend($task->{domain},$initial->[0]) and return 1; warn "failed to create fd for DNS/MX($!)\n"; 0; }; last; }; } @task or last; my $to = $task[0]{expire} - $now; my $rmask = my $wmask = ''; for(@task) { vec($rmask,fileno($_->{fd}),1) = 1 if $_->{wantread}; vec($wmask,fileno($_->{fd}),1) = 1 if $_->{wantwrite}; } $0 = sprintf("scan tasks=%d done=%d defered=%d to=%d",@task+0,$done,@defer_task+0,$to); my $rv = select($rmask,$wmask,undef,$to); $rv or next; for(my $i=0;1;$i++) { my $task = $task[$i] or last; for([ wantread => $rmask ],[ wantwrite => $wmask ]) { $task->{fd} or last; if (vec($_->[1],fileno($task->{fd}),1) and my $sub = delete $task->{$_->[0]}) { $sub->($task); } } if (!$task->{result} && !@{$task->{ssl_tests}}) { # final result my $succ = $task->{ssl_success}; $task->{result} = $succ ? "tls:$succ->{id}:$succ->{version}/$succ->{cipher}" : "-tls"; } if ($task->{result}) { my $info = $task->{info} ? " ".join(";",@{$task->{info}}) :""; print "$task->{domain} $task->{result}$info\n"; splice(@task,$i,1); $done++; for(@{$task->{related_tasks} || []}) { print "$_->{domain} $task->{result}$info\n"; $done++; } redo; } elsif ($task->{resume}) { push @defer_task,$task; splice(@task,$i,1); redo; } elsif ($task->{related}) { # not active by its own splice(@task,$i,1); redo; } } } sub dns_mx { my $task = shift; DEBUG($task,"get mx"); my $pkt = $res->bgread($task->{fd}) or do { $task->{wantread} = \&dns_mx; return; }; my @mx = map { $_->exchange } sort { $a->preference <=> $b->preference } grep { $_->type eq 'MX' } $pkt->answer; if (!@mx) { # check if the given name is instead the MX itself $task->{nomx} = 1; @mx = $task->{domain}; } my %name2ip = map { $_->type eq 'A' ? ( $_->name,$_->address ):() } $pkt->additional; my $ip = $name2ip{lc($mx[0])}; if (!$ip) { $task->{wantread} = \&dns_name2a, $task->{fd} = $res->bgsend($mx[0],'A'); if (!$task->{fd}) { $task->{resume} = sub { my $task = shift; $task->{fd} = $res->bgsend($mx[0],'A') and return 1; warn "failed to create fd for DNS/A($!)\n"; 0; }; } return; } return tcp_connect($task,$ip); } sub dns_name2a { my $task = shift; DEBUG($task,"get addr to mx"); my $pkt = $res->bgread($task->{fd}) or do { $task->{wantread} = \&dns_name2a; return; }; my ($ip) = map { $_->type eq 'A' ? ($_->address):() } $pkt->answer; if (!$ip) { if (delete $task->{nomx}) { DEBUG($task,"no mx found"); $task->{result} = '-nomx'; } else { DEBUG($task,"no addr to mx found"); $task->{result} = '-nomxip'; } return; } DEBUG($task,"assuming name is MX already") if delete $task->{nomx}; return tcp_connect($task,$ip); } sub tcp_connect { my ($task,$ip) = @_; $task->{ip} = $ip; $task->{state} = 'tcp'; # check for other tasks to same IP for(@task) { if ($_ != $task and $_->{ip} and $_->{ip} eq $ip) { $task->{related} = 1; DEBUG($task,"mark as related to $_->{domain}, ip=$ip"); push @{$_->{related_tasks}},$task; return 1; } } DEBUG($task,"start TCP connect to $ip"); my $fd = $task->{fd} = IO::Socket::INET->new(Proto => 'tcp'); if(!$fd) { warn "failed to create INET socket: $!\n"; $task->{resume} = sub { return tcp_connect(shift(),$ip) }; return 0; } $fd->blocking(0); my $saddr = pack_sockaddr_in(25,inet_aton($ip)); if (connect($fd,$saddr)) { # immediate success smtp_read_greeting($task); 1; } if (! $!{EINPROGRESS} && !$!{EALREADY}) { DEBUG($task,"TCP connection to $ip failed($!)"); $task->{result} = "-tcpconn($!)"; return 1; } $task->{saddr} = $saddr; $task->{wantwrite} = \&tcp_finish_connect; 1; } sub tcp_finish_connect { my $task = shift; if (connect($task->{fd},$task->{saddr})) { return smtp_read_greeting($task); } if (! $!{EINPROGRESS} && !$!{EALREADY}) { DEBUG($task,"TCP connection to $task->{ip} failed: $!"); $task->{result} = "-tcpconn($!)"; return; } $task->{wantwrite} = \&tcp_finish_connect; } sub smtp_read_greeting { my $task = shift; DEBUG($task,"read SMTP greeting"); $task->{state} = 'smtp'; $task->{rbuf} //= ''; my $n = sysread($task->{fd}, $task->{rbuf}, 4096, length($task->{rbuf})); if (!$n) { goto again if !defined $n && $!{EWOULDBLOCK}; DEBUG($task,"got EOF in SMTP greeting"); $task->{result} = '-smtp-greeting:eof'; return; } if ($task->{rbuf} =~s{\A($smtp_resp)}{}) { if ($2 != 2) { (my $l = $1) =~s{\r?\n}{}g; $l =~s{$}{}; DEBUG($task,"got error in SMTP greeting: $l"); $task->{result}= "-smtp-greeting:$l"; } else { $task->{fd}->print("EHLO $ehlo_domain\r\n"); $task->{wantread} = \&smtp_read_ehlo; } return; } else { goto again; } again: $task->{wantread} = \&smtp_read_greeting; } sub smtp_read_ehlo { my $task = shift; DEBUG($task,"read SMTP ehlo response"); my $n = sysread($task->{fd}, $task->{rbuf}, 4096, length($task->{rbuf})); if (!$n) { goto again if !defined $n && $!{EWOULDBLOCK}; DEBUG($task,"EOF in SMTP ehlo response"); $task->{result} = '-smtp-ehlo:eof'; return; } if ($task->{rbuf} =~s{\A($smtp_resp)}{}) { my $l = $1; if ($2 != 2) { $l =~s{\r?\n}{}g; $l =~s{$}{}; DEBUG($task,"error in SMTP ehlo response: $l"); $task->{result}= "-smtp-ehlo=$l"; } elsif ($l =~m{STARTTLS}i) { $task->{fd}->print("STARTTLS\r\n"); $task->{wantread} = \&smtp_read_starttls; } else { DEBUG($task,"no STARTTLS support"); $task->{result} = "-no-starttls"; } return; } else { goto again; } again: $task->{wantread} = \&smtp_read_ehlo; } sub smtp_read_starttls { my $task = shift; DEBUG($task,"read SMTP starttls response"); my $n = sysread($task->{fd}, $task->{rbuf}, 4096, length($task->{rbuf})); if (!$n) { goto again if !defined $n && $!{EWOULDBLOCK}; DEBUG($task,"EOF in read SMTP starttls response"); $task->{result} = '-smtp-starttls:eof'; return; } if ($task->{rbuf} =~s{\A($smtp_resp)}{}) { my $l = $1; if ($2 != 2) { $l =~s{\r?\n}{}g; $l =~s{$}{}; DEBUG($task,"error in read SMTP starttls response: $l"); $task->{result}= "-smtp-starttls=$l"; } else { my (undef,undef,%sslargs) = @{$task->{ssl_tests}[0]}; IO::Socket::SSL->start_SSL($task->{fd}, SSL_version => 'SSLv23', SSL_cipher_list => $ciphers, %sslargs, SSL_verify_mode => 0, SSL_startHandshake => 0, ) or die $SSL_ERROR; return ssl_connect($task); } return; } else { goto again; } again: $task->{wantread} = \&smtp_read_starttls; } sub ssl_connect { my $task = shift; $task->{state} = 'tls'; my $ssl_tests = $task->{ssl_tests}; my ($id,undef,%sslargs) = @{$ssl_tests->[0]}; my $result; if ($task->{fd}->connect_SSL) { my $version = $task->{fd}->get_sslversion; my $cipher = $task->{fd}->get_cipher; DEBUG($task,"success in TLS connect $id"); $result = "+tls:$id:$version/$cipher"; $task->{ssl_success} ||= { id => $id, version => $version, cipher => $cipher, }; } elsif ($!{EWOULDBLOCK}) { if ($SSL_ERROR == SSL_WANT_READ) { DEBUG($task,"want read in TLS connect $id"); $task->{wantread} = \&ssl_connect; return; } elsif ($SSL_ERROR == SSL_WANT_WRITE) { DEBUG($task,"want write in TLS connect $id"); $task->{wantwrite} = \&ssl_connect; return; } } if (!$result) { DEBUG($task,"error in TLS connect $id: $SSL_ERROR"); return _next_ssl_test($task,"-tls:$SSL_ERROR"); } $task->{fd}->print("EHLO $ehlo_domain\r\n"); $task->{wantread} = \&ssl_read_ehlo; } sub ssl_read_ehlo { my $task = shift; DEBUG($task,"read SMTP ehlo response after STARTTLS"); my $n = sysread($task->{fd}, $task->{rbuf}, 16384, length($task->{rbuf})); if (!defined $n) { if ($!{EWOULDBLOCK}) { if ($SSL_ERROR == SSL_WANT_READ) { DEBUG($task,"want read in TLS ehlo"); $task->{wantread} = \&ssl_read_ehlo, return; } elsif ($SSL_ERROR == SSL_WANT_WRITE) { DEBUG($task,"want write in TLS ehlo"); $task->{wantwrite} = \&ssl_read_ehlo, return; } } DEBUG($task,"error in TLS ehlo: $SSL_ERROR"); $task->{result}= "-tls:ehlo:$SSL_ERROR"; return; } if (!$n) { DEBUG($task,"EOF in SMTP ehlo response after starttls"); $task->{result} = '-tls:ehlo-eof'; return; } if ($task->{rbuf} =~s{\A($smtp_resp)}{}) { my $l = $1; if ($2 != 2) { $l =~s{\r?\n}{}g; $l =~s{$}{}; DEBUG($task,"error in TLS ehlo response: $l"); return _next_ssl_test($task,"-tls:ehlo=$l"); } else { DEBUG($task,"success in TLS ehlo response"); return _next_ssl_test($task,"+tls:".$task->{fd}->get_sslversion."/".$task->{fd}->get_cipher); } } # need more DEBUG($task,"TLS ehlo response - need more data"); $task->{wantread} = \&ssl_read_ehlo, } sub _next_ssl_test { my ($task,$result) = @_; # done with this test my $ssl_tests = $task->{ssl_tests}; my ($id) = @{ $ssl_tests->[0] }; $result =~s{^(.tls:)}{$1$id:} or die $result; push @{$task->{info}}, $result; shift(@$ssl_tests); # find next test while (@$ssl_tests) { my ($id,$runif) = @{ $ssl_tests->[0] }; if ($runif->($task)) { #warn "next test: $id\n"; last; } else { #warn "skip test: $id\n"; shift(@$ssl_tests); } } if(@$ssl_tests) { # non-final, do next test $task->{expire} = time() + $timeout; return tcp_connect($task,$task->{ip}); } } # create self-signed client certificate sub create_client_cert { my $digest = shift || 'sha256'; my $name = shift || 'ssl.test'; my ($cert,$key) = CERT_create( digest => $digest, CA => 1, subject => { CN => $name }, ext => [ { sn => 'keyUsage', data => 'critical,digitalSignature,keyEncipherment,keyCertSign' }, { sn => 'extendedKeyUsage', data => 'serverAuth,clientAuth', } ] ); return { cert => $cert, key => $key }; } sub DEBUG { $DEBUG or return; my $task = shift; my $msg = @_>1 ? shift : '%s'; printf STDERR "DEBUG %.3f %s $msg\n",0+gettimeofday(),$task->{domain},@_; }