qpsmtpd/plugins/tls

#!perl -w

=head1 NAME

tls - plugin to support STARTTLS

=head1 SYNOPSIS

# in config/plugins

  tls ssl/cert.pem ssl/privkey.pem ssl/ca.pem

=head1 DESCRIPTION

This plugin implements basic TLS support.

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.

=cut

use IO::Socket::SSL;# 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);
    
    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 => 'HIGH',
        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");
    
    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 => 'HIGH',
            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_enabled', 1);
    };
    if ($@) {
        # 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 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 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;