#!/usr/bin/perl
#
# $HeadURL: https://svn.spodhuis.org/ksvn/pdp-bincommon/smtp_tls_cert.pl $
# $Id: smtp_tls_cert.pl 506 2012-05-24 01:22:55Z pdp@SPODHUIS.ORG $
#
# Connect to an SMTP service, use STARTTLS for TLS promotion, dump the
# raw certificate (PEM-encoded).

use warnings;
use strict;

# Logic ripped from sieve_connect (which I also wrote)
# Net::SSLeay usage partially ripped from Net::SSLeay manpage
# and partially from IO::Socket::SSL.

my $DEBUGGING = exists $ENV{'DEBUG'} ? 1 : 0;
my %ssl_options = (
	SSL_version	=> 'SSLv23:!SSLv2:!SSLv3',
	SSL_cipher_list	=> 'ALL:!NULL:!LOW:!EXP:!ADH:@STRENGTH',
	SSL_verify_mode	=> 0x01,
#	SSL_ca_path	=> '/etc/ssl/certs',
	Proto		=> 'tcp',
);

use IO::Socket;
use IO::Socket::INET6;
use Net::SSLeay;
use Sys::Hostname ();

sub debug;
sub sent;
sub ssend;
sub sget;
sub sfinish;
sub received;
sub start_tls;

my $server = $ARGV[0];
my $port = defined $ARGV[1] ? $ARGV[1] : 587;
die "Usage: $0 <server>\n" unless defined $server;
die "Bad server name\n"
	unless $server =~ /^[A-Za-z0-9_.-]+\z/;

my $hostname = Sys::Hostname::hostname();

my $sock = IO::Socket::INET6->new(
	PeerHost	=> $server,
	PeerPort	=> $port,
	Proto		=> 'tcp',
);
die "socket(): $!\n" unless defined $sock;
$sock->autoflush(1);

sget $sock;
ssend $sock, "EHLO $hostname";
sget $sock;
ssend $sock, "STARTTLS";
sget $sock;
my $ssl = start_tls($sock, \%ssl_options);
if (not defined $ssl) {
	$ssl = { error => "unknown error ($!)?" };
}
if (exists $ssl->{error}) {
	my $e = $ssl->{error};
	die "STARTTLS promotion failed: $e\n";
};
print Net::SSLeay::PEM_get_string_X509(
	Net::SSLeay::get_peer_certificate($ssl->{ssl_obj})
	);

Net::SSLeay::ssl_write_CRLF($ssl->{ssl_obj}, "QUIT");
print "\n";
exit 0;


sub debug
{
	return unless $DEBUGGING;
	print STDERR $_[0] =~ /\n\z/ ? $_[0] : "$_[0]\n";
}

sub sent { $_[0] = $_ unless defined $_[0]; debug ">>> $_[0]"; }
sub received { $_[0] = $_ unless defined $_[0]; debug "<<< $_[0]"; }

sub ssend
{
	my $sock = shift;
	my $eol = "\r\n";
	if (defined $_[0] and $_[0] eq '-noeol') {
		shift;
		$eol = '';
	}
	foreach my $l (@_) {
		$sock->print("$l$eol");
# yes, the debug output can have extra blank lines if supplied -noeol because
# they're already present.  Rather than mess around to tidy it up, I'm leaving
# it because it's debug output, not UI or protocol text.
		sent $l;
	}
}

sub sget
{
	my $sock = shift;
	my $l;
	my @lines;
	$l = $sock->getline();
	while (defined $l and $l =~ /^\d{3}-/) {
		push @lines, $l;
		$l = $sock->getline();
	}
	push @lines, $l if defined $l;
	for my $i (@lines) { received $i }
	return @lines if wantarray;
	$_ = join('', @lines);
}

sub start_tls
{
	my $sock = shift;
	my $options = shift;

	Net::SSLeay::load_error_strings();
	Net::SSLeay::SSLeay_add_ssl_algorithms();
	Net::SSLeay::randomize();

 my $tls_options = Net::SSLeay::OP_NO_SSLv2() | Net::SSLeay::OP_NO_SSLv3();

	my $fileno = fileno($sock);
	my $ctx = Net::SSLeay::CTX_v23_new();
	return { error => "SSL context init failed: $!" } unless $ctx;
	Net::SSLeay::CTX_set_options($ctx, $tls_options) # returns new options bitmask
		or return { error => "SSL context option set failed: $!" };
	if (exists $options->{SSL_ca_path}) {
		Net::SSLeay::CTX_load_verify_locations($ctx, '', $options->{SSL_ca_path})
			or return { error => "Invalid CA path" };
	} else {
		Net::SSLeay::CTX_set_default_verify_paths($ctx);
	}
	Net::SSLeay::CTX_set_verify($ctx, $options->{SSL_verify_mode}, 0)
		if exists $options->{SSL_verify_mode};

	my $ssl_obj = Net::SSLeay::new($ctx);
	Net::SSLeay::set_fd($ssl_obj, $fileno)
		or return { error => "SSL filehandle association failed" };
	if (exists $options->{SSL_cipher_list}) {
		Net::SSLeay::set_cipher_list($ssl_obj, $options->{SSL_cipher_list})
			or return { error => "Failed to set SSL cipher list" };
	}

	my $res = Net::SSLeay::connect($ssl_obj);
	return { error => "SSL setup failed at start" } if $res < 0;
	return { error => "SSL setup failed handshake" } if $res == 0;

	return {
		sock => $sock,
		options => $options,
		ssl_obj => $ssl_obj,
	};
}