qpsmtpd/plugins/tls

#!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 strict;

use IO::Socket::SSL 0.98;

use Qpsmtpd::Constants;

sub init {
    my ($self, $qp, $cert, $key, $ca) = @_;
    my $dir = -d 'ssl' ? 'ssl' : 'config/ssl';
    $cert ||= "$dir/qpsmtpd-server.crt";
    $key  ||= "$dir/qpsmtpd-server.key";
    $ca   ||= "$dir/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(LOGDEBUG, "ciphers: " . $self->tls_ciphers);

    local $^W;    # this bit is very noisy...
    my $ssl_ctx =
      IO::Socket::SSL::SSL_Context->new(
                                        # Disable SSLv2 and SSLv3 to avoid POODLE attacks. This is already
                                        # the default in sufficiently recent versions of IO::Socket::SSL
                                        SSL_version => 'SSLv23:!SSLv3:!SSLv2',
                                        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') || [];
    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 lc $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(LOGINFO, "TLS setup returning");
    return DONE;
}

sub hook_connect {
    my ($self, $transaction) = @_;

    my $local_port = $self->qp->connection->local_port;
    if ( ! defined $local_port || $local_port != 465 ) {  # SMTPS
        $self->log(LOGDEBUG, "skip, not SMTPS");
        return DECLINED;
    };

    unless (_convert_to_ssl($self)) {
        $self->log(LOGINFO, "fail, unable to establish SSL");
        return DENY_DISCONNECT, "Cannot establish SSL session";
    }
    $self->log(LOGINFO, "pass, connect 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) = @_;

    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;
    }
    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 '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();
    }
}