328 lines
9.1 KiB
Plaintext
328 lines
9.1 KiB
Plaintext
|
#!perl -w
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
tls - plugin to support STARTTLS
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
# in config/plugins
|
||
|
|
|
||
|
|
tls [B<cert_path priv_key_path ca_path>]
|
||
|
|
|
||
|
|
=over 4
|
||
|
|
|
||
|
|
=item B<cert_path>
|
||
|
|
|
||
|
|
Path to the server certificate file. Default: I<ssl/qpsmtpd-server.crt>
|
||
|
|
|
||
|
|
=item B<priv_key_path>
|
||
|
|
|
||
|
|
Path to the private key file. Default: I<ssl/qpsmtpd-server.key>
|
||
|
|
|
||
|
|
=item B<ca_path>
|
||
|
|
|
||
|
|
Path to the certificate authority file. Default: I<ssl/qpsmtpd-ca.crt>
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=head1 DESCRIPTION
|
||
|
|
|
||
|
|
This plugin implements basic TLS support. It can also be used to support
|
||
|
|
port 465 (SMTP over SSL), but only with qpsmtpd-forkserver. In this case,
|
||
|
|
be sure to load plugins/tls before any other connect plugins and start
|
||
|
|
qpsmtpd like this:
|
||
|
|
|
||
|
|
qpsmtpd-forkserver --port 25 --port 465
|
||
|
|
|
||
|
|
You can also specify multiple --listen-address options as well; see the help
|
||
|
|
for qpsmtpd-forkserver for more details.
|
||
|
|
|
||
|
|
If TLS is successfully negotiated then the C<tls_enabled> field in the
|
||
|
|
Connection notes is set. If you wish to make TLS mandatory you should check
|
||
|
|
that field and take appropriate action. Note that you can only do that from
|
||
|
|
MAIL FROM onwards.
|
||
|
|
|
||
|
|
Use the script C<plugins/tls_cert> to automatically generate a self-signed
|
||
|
|
certificate with the appropriate characteristics. Otherwise, you should
|
||
|
|
give absolute pathnames to the certificate, key, and the CA root cert
|
||
|
|
used to sign that certificate.
|
||
|
|
|
||
|
|
=head1 CIPHERS and COMPATIBILITY
|
||
|
|
|
||
|
|
By default, we use only the plugins that openssl considers to be
|
||
|
|
"high security". If you need to tweak the available ciphers for some
|
||
|
|
broken client (such as Versamail 3.x), have a look at the available
|
||
|
|
ciphers at L<http://www.openssl.org/docs/apps/ciphers.html#CIPHER_STRINGS>,
|
||
|
|
and put a suitable string in config/tls_ciphers (e.g. "DEFAULT" or
|
||
|
|
"HIGH:MEDIUM")
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
use IO::Socket::SSL 0.98; # qw(debug1 debug2 debug3 debug4);
|
||
|
|
|
||
|
|
sub init {
|
||
|
|
my ($self, $qp, $cert, $key, $ca) = @_;
|
||
|
|
$cert ||= 'ssl/qpsmtpd-server.crt';
|
||
|
|
$key ||= 'ssl/qpsmtpd-server.key';
|
||
|
|
$ca ||= 'ssl/qpsmtpd-ca.crt';
|
||
|
|
unless ( -f $cert && -f $key && -f $ca ) {
|
||
|
|
$self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$self->tls_cert($cert);
|
||
|
|
$self->tls_key($key);
|
||
|
|
$self->tls_ca($ca);
|
||
|
|
$self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH');
|
||
|
|
|
||
|
|
$self->log(LOGINFO, "ciphers: ".$self->tls_ciphers);
|
||
|
|
|
||
|
|
local $^W; # this bit is very noisy...
|
||
|
|
my $ssl_ctx = IO::Socket::SSL::SSL_Context->new(
|
||
|
|
SSL_use_cert => 1,
|
||
|
|
SSL_cert_file => $self->tls_cert,
|
||
|
|
SSL_key_file => $self->tls_key,
|
||
|
|
SSL_ca_file => $self->tls_ca,
|
||
|
|
SSL_cipher_list => $self->tls_ciphers,
|
||
|
|
SSL_server => 1
|
||
|
|
) or die "Could not create SSL context: $!";
|
||
|
|
# now extract the password...
|
||
|
|
|
||
|
|
$self->ssl_context($ssl_ctx);
|
||
|
|
|
||
|
|
# Check for possible AUTH mechanisms
|
||
|
|
HOOK: foreach my $hook ( keys %{$qp->hooks} ) {
|
||
|
|
no strict 'refs';
|
||
|
|
if ( $hook =~ m/^auth-?(.+)?$/ ) {
|
||
|
|
if ( defined $1 ) {
|
||
|
|
my $hooksub = "hook_$hook";
|
||
|
|
$hooksub =~ s/\W/_/g;
|
||
|
|
*$hooksub = \&bad_ssl_hook;
|
||
|
|
}
|
||
|
|
else { # at least one polymorphous auth provider
|
||
|
|
*hook_auth = \&bad_ssl_hook;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub hook_ehlo {
|
||
|
|
my ($self, $transaction) = @_;
|
||
|
|
return DECLINED unless $self->can_do_tls;
|
||
|
|
return DECLINED if $self->connection->notes('tls_enabled');
|
||
|
|
return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
|
||
|
|
my $cap = $transaction->notes('capabilities');
|
||
|
|
$cap ||= [];
|
||
|
|
push @$cap, 'STARTTLS';
|
||
|
|
$transaction->notes('tls_enabled', 1);
|
||
|
|
$transaction->notes('capabilities', $cap);
|
||
|
|
return DECLINED;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub hook_unrecognized_command {
|
||
|
|
my ($self, $transaction, $cmd, @args) = @_;
|
||
|
|
return DECLINED unless $cmd eq 'starttls';
|
||
|
|
return DECLINED unless $transaction->notes('tls_enabled');
|
||
|
|
return DENY, "Syntax error (no parameters allowed)" if @args;
|
||
|
|
|
||
|
|
# OK, now we setup TLS
|
||
|
|
$self->qp->respond (220, "Go ahead with TLS");
|
||
|
|
|
||
|
|
unless ( _convert_to_ssl($self) ) {
|
||
|
|
# SSL setup failed. Now we must respond to every command with 5XX
|
||
|
|
warn("TLS failed: $@\n");
|
||
|
|
$transaction->notes('ssl_failed', 1);
|
||
|
|
return DENY, "TLS Negotiation Failed";
|
||
|
|
}
|
||
|
|
|
||
|
|
$self->log(LOGWARN, "TLS setup returning");
|
||
|
|
return DONE;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub hook_connect {
|
||
|
|
my ($self, $transaction) = @_;
|
||
|
|
|
||
|
|
my $local_port = $self->qp->connection->local_port;
|
||
|
|
return DECLINED unless defined $local_port && $local_port == 465; # SMTPS
|
||
|
|
|
||
|
|
unless ( _convert_to_ssl($self) ) {
|
||
|
|
return (DENY_DISCONNECT, "Cannot establish SSL session");
|
||
|
|
}
|
||
|
|
$self->log(LOGWARN, "Connected via SMTPS");
|
||
|
|
return DECLINED;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub hook_post_connection {
|
||
|
|
my ($self, $transaction) = @_;
|
||
|
|
|
||
|
|
my $tls_socket = $self->connection->notes('tls_socket');
|
||
|
|
if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped')) {
|
||
|
|
$tls_socket->close;
|
||
|
|
$self->connection->notes('tls_socket', undef);
|
||
|
|
$self->connection->notes('tls_socked_is_duped', 0);
|
||
|
|
}
|
||
|
|
|
||
|
|
return DECLINED;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _convert_to_ssl {
|
||
|
|
my ($self) = @_;
|
||
|
|
|
||
|
|
if ($self->qp->isa('Qpsmtpd::PollServer')) {
|
||
|
|
return _convert_to_ssl_async($self);
|
||
|
|
}
|
||
|
|
|
||
|
|
eval {
|
||
|
|
my $tlssocket = IO::Socket::SSL->new_from_fd(
|
||
|
|
fileno(STDIN), '+>',
|
||
|
|
SSL_use_cert => 1,
|
||
|
|
SSL_cert_file => $self->tls_cert,
|
||
|
|
SSL_key_file => $self->tls_key,
|
||
|
|
SSL_ca_file => $self->tls_ca,
|
||
|
|
SSL_cipher_list => $self->tls_ciphers,
|
||
|
|
SSL_server => 1,
|
||
|
|
SSL_reuse_ctx => $self->ssl_context,
|
||
|
|
) or die "Could not create SSL socket: $!";
|
||
|
|
|
||
|
|
# Clone connection object (without data received from client)
|
||
|
|
$self->qp->connection($self->connection->clone());
|
||
|
|
$self->qp->reset_transaction;
|
||
|
|
*STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket);
|
||
|
|
$self->connection->notes('tls_socket_is_duped', 1);
|
||
|
|
$self->connection->notes('tls_enabled', 1);
|
||
|
|
};
|
||
|
|
if ($@) {
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _convert_to_ssl_async {
|
||
|
|
my ($self) = @_;
|
||
|
|
my $upgrader = $self->connection
|
||
|
|
->notes( 'tls_upgrader', UpgradeClientSSL->new($self) );
|
||
|
|
$upgrader->upgrade_socket();
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub can_do_tls {
|
||
|
|
my ($self) = @_;
|
||
|
|
$self->tls_cert && -r $self->tls_cert;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub tls_cert {
|
||
|
|
my $self = shift;
|
||
|
|
@_ and $self->{_tls_cert} = shift;
|
||
|
|
$self->{_tls_cert};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub tls_key {
|
||
|
|
my $self = shift;
|
||
|
|
@_ and $self->{_tls_key} = shift;
|
||
|
|
$self->{_tls_key};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub tls_ca {
|
||
|
|
my $self = shift;
|
||
|
|
@_ and $self->{_tls_ca} = shift;
|
||
|
|
$self->{_tls_ca};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub tls_ciphers {
|
||
|
|
my $self = shift;
|
||
|
|
@_ and $self->{_tls_ciphers} = shift;
|
||
|
|
$self->{_tls_ciphers};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub ssl_context {
|
||
|
|
my $self = shift;
|
||
|
|
@_ and $self->{_ssl_ctx} = shift;
|
||
|
|
$self->{_ssl_ctx};
|
||
|
|
}
|
||
|
|
|
||
|
|
# Fulfill RFC 2487 secn 5.1
|
||
|
|
sub bad_ssl_hook {
|
||
|
|
my ($self, $transaction) = @_;
|
||
|
|
return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
|
||
|
|
return DECLINED;
|
||
|
|
}
|
||
|
|
*hook_helo = *hook_data = *hook_rcpt = *hook_mail = \&bad_ssl_hook;
|
||
|
|
|
||
|
|
package UpgradeClientSSL;
|
||
|
|
|
||
|
|
# borrowed heavily from Perlbal::SocketSSL
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use warnings;
|
||
|
|
no warnings qw(deprecated);
|
||
|
|
|
||
|
|
use IO::Socket::SSL 0.98;
|
||
|
|
use Errno qw( EAGAIN );
|
||
|
|
|
||
|
|
use fields qw( _stashed_qp _stashed_plugin _ssl_started );
|
||
|
|
|
||
|
|
sub new {
|
||
|
|
my UpgradeClientSSL $self = shift;
|
||
|
|
$self = fields::new($self) unless ref $self;
|
||
|
|
$self->{_stashed_plugin} = shift;
|
||
|
|
$self->{_stashed_qp} = $self->{_stashed_plugin}->qp;
|
||
|
|
return $self;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub upgrade_socket {
|
||
|
|
my UpgradeClientSSL $self = shift;
|
||
|
|
|
||
|
|
unless ( $self->{_ssl_started} ) {
|
||
|
|
$self->{_stashed_qp}->clear_data();
|
||
|
|
IO::Socket::SSL->start_SSL(
|
||
|
|
$self->{_stashed_qp}->{sock}, {
|
||
|
|
SSL_use_cert => 1,
|
||
|
|
SSL_cert_file => $self->{_stashed_plugin}->tls_cert,
|
||
|
|
SSL_key_file => $self->{_stashed_plugin}->tls_key,
|
||
|
|
SSL_ca_file => $self->{_stashed_plugin}->tls_ca,
|
||
|
|
SSL_cipher_list => $self->{_stashed_plugin}->tls_ciphers,
|
||
|
|
SSL_startHandshake => 0,
|
||
|
|
SSL_server => 1,
|
||
|
|
SSL_reuse_ctx => $self->{_stashed_plugin}->ssl_context,
|
||
|
|
}
|
||
|
|
) or die "Could not upgrade socket to SSL: $!";
|
||
|
|
$self->{_ssl_started} = 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
$self->event_read($self->{_stashed_qp});
|
||
|
|
}
|
||
|
|
|
||
|
|
sub event_read {
|
||
|
|
my UpgradeClientSSL $self = shift;
|
||
|
|
my $qp = shift;
|
||
|
|
|
||
|
|
$qp->watch_read( 0 );
|
||
|
|
|
||
|
|
my $sock = $qp->{sock}->accept_SSL;
|
||
|
|
|
||
|
|
if (defined $sock) {
|
||
|
|
$qp->connection( $qp->connection->clone );
|
||
|
|
$qp->reset_transaction;
|
||
|
|
$self->connection->notes('tls_socket', $sock);
|
||
|
|
$self->connection->notes('tls_enabled', 1);
|
||
|
|
$qp->watch_read(1);
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# nope, let's see if we can continue the process
|
||
|
|
if ($! == EAGAIN) {
|
||
|
|
$qp->set_reader_object($self);
|
||
|
|
if ($SSL_ERROR == SSL_WANT_READ) {
|
||
|
|
$qp->watch_read(1);
|
||
|
|
} elsif ($SSL_ERROR == SSL_WANT_WRITE) {
|
||
|
|
$qp->watch_write(1);
|
||
|
|
} else {
|
||
|
|
$qp->disconnect();
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$qp->disconnect();
|
||
|
|
}
|
||
|
|
}
|