#!/usr/bin/perl -w

################################################################################
# cipher-audit.pl v0.2
#
# Copyright (c) 2008 Brian Keefer <chort@smtps.net> All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote
#    products derived from this software without specific prior written
#    permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
################################################################################

use strict;
use IO::Socket::SSL;

sub walk_cipher_list;
sub attempt_connection;
sub report_ciphers;

my $host	= shift or die 'Usage: ' . $0 . ' <hostname|IP address>' . "\n";
my $port	= '443';
my $openssl     = `which openssl`;
chomp($openssl);
my $debug	= 0;

my $e_ciphers = qx($openssl ciphers EXPORT);
my $l_ciphers = qx($openssl ciphers LOW);
my $m_ciphers = qx($openssl ciphers MEDIUM);
my $h_ciphers = qx($openssl ciphers HIGH);

my @e_ciphers	= walk_cipher_list($host, $port, split(':', $e_ciphers));
my $e_len	= scalar @e_ciphers;
my @l_ciphers	= walk_cipher_list($host, $port, split(':', $l_ciphers));
my $l_len	= scalar @l_ciphers;
my @m_ciphers	= walk_cipher_list($host, $port, split(':', $m_ciphers));
my $m_len	= scalar @m_ciphers;
my @h_ciphers	= walk_cipher_list($host, $port, split(':', $h_ciphers));
my $h_len	= scalar @h_ciphers;

if ($e_len > 0) {
	report_ciphers($host, 'EXPORT', @e_ciphers);
} else {
	print "$host does NOT support EXPORT ciphers.\n";
}
if ($l_len > 0) {
	report_ciphers($host, 'LOW', @l_ciphers);
} else {
	print "$host does NOT support LOW ciphers.\n";
}
if ($m_len > 0) {
	report_ciphers($host, 'MEDIUM', @m_ciphers);
} else {
	print "$host does NOT support MEDIUM ciphers.\n";
}
if ($h_len > 0) {
	report_ciphers($host, 'HIGH', @h_ciphers);
} else {
	print "$host does NOT support HIGH ciphers.\n";
}

sub walk_cipher_list {
	my $h = shift;
	my $p = shift;
	my @c = @_;
	my @accepted;

	foreach my $c (@c) {
		my $ret = attempt_connection($h, $p, $c);
		if ( $ret == 0 ) {
			push(@accepted, $c);
		}
	}
	return @accepted;
}

sub attempt_connection {
	my ($h, $p, $c) = @_;
	print "Attempting connection with $c\n" if $debug;
	my $client = IO::Socket::SSL->new(
		PeerAddr => $h,
		PeerPort => $p,
		SSL_cipher_list => $c);
		#or warn 'Problem setting up socket: ' . IO::Socket::SSL::errstr();

	if (defined($client)) {
		print "$c got past connecting\n" if $debug;
		print $client 'GET / HTTP/1.0' . "\r\n\r\n";
		print <$client> if $debug;
		$client->close(SSL_fast_shutdown => 1);
		return 0;
	}
	return 1;
}

sub report_ciphers {
	my $h		= shift;
	my $s		= shift;
	my @c		= @_;
	my $len		= scalar @c;

	print $h . ' supports ' . $len . ' ' . $s . ' cipher(s)!' . "\n";

	print 'Cipher(s) is/are:';
	foreach my $c (@c) {
		print ' ' . $c;
	}
	print "\n";
}