view release on metacpan or  search on metacpan

lib/DJabberd/Stanza/StartTLS.pm  view on Meta::CPAN

package DJabberd::Stanza::StartTLS;
use strict;
use base qw(DJabberd::Stanza);
use Net::SSLeay qw(ERROR_WANT_READ ERROR_WANT_WRITE ERROR_SYSCALL);

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

sub on_recv_from_server { &process }
sub on_recv_from_client { &process }

sub process {
    my ($self, $conn) = @_;

    # {=tls-no-spaces} -- we can't send spaces after the closing bracket
    $conn->write("<proceed xmlns='urn:ietf:params:xml:ns:xmpp-tls' />");

    my $ctx = Net::SSLeay::CTX_new()
        or die("Failed to create SSL_CTX $!");

    $Net::SSLeay::ssl_version = 10; # Insist on TLSv1
    #$Net::SSLeay::ssl_version = 3; # Insist on SSLv3

    Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL)
        and Net::SSLeay::die_if_ssl_error("ssl ctx set options");

    Net::SSLeay::CTX_set_mode($ctx, 1)  # enable partial writes
        and Net::SSLeay::die_if_ssl_error("ssl ctx set options");

    # Following will ask password unless private key is not encrypted
    Net::SSLeay::CTX_use_RSAPrivateKey_file ($ctx,  $conn->vhost->server->ssl_private_key_file,
                                             &Net::SSLeay::FILETYPE_PEM);
    Net::SSLeay::die_if_ssl_error("private key");

    Net::SSLeay::CTX_use_certificate_file ($ctx, $conn->vhost->server->ssl_cert_file,
                                           &Net::SSLeay::FILETYPE_PEM);
    Net::SSLeay::die_if_ssl_error("certificate");

    if ($conn->vhost->server->ssl_cert_chain_file) {
        Net::SSLeay::CTX_use_certificate_chain_file ($ctx, $conn->vhost->server->ssl_cert_chain_file);
        Net::SSLeay::die_if_ssl_error("certificate chain file");
    }


    my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");
    $conn->{ssl} = $ssl;
    $conn->restart_stream;
    
    DJabberd::Stanza::StartTLS->finalize_ssl_negotiation($conn, $ssl, $ctx);
}

# Complete the transformation of stream from tcp socket into ssl socket:
# 1. setup disconnect handler to free memory for $ssl and $ctx on connection close
# 2. SSL object is connected to underlying connection socket
# 3. 'accept' tells SSL to start negotiating encryption
# 4. set a socket write function that encrypts data before writting to the underlying socket
sub finalize_ssl_negotiation {
    my ($class, $conn, $ssl, $ctx) = @_;

    # Add a disconnect handler to this connection that will free memory
    # and remove references to junk no longer needed on close
    $conn->add_disconnect_handler(sub { 
         $conn->set_writer_func(sub { return 0 });
         Net::SSLeay::free($ssl);
         # Currently, a CTX_new is being called for every SSL connection.
         # It would be more efficient to create one $ctx per-vhost instead of per-connection
         # and to re-use that $ctx object for each new connection to that vhost.
         # This would eliminate the need to free $ctx here.
         Net::SSLeay::CTX_free($ctx);
         $conn->{ssl} = undef;
    });

    my $fileno = $conn->{sock}->fileno;
    warn "setting ssl ($ssl) fileno to $fileno\n";
    Net::SSLeay::set_fd($ssl, $fileno);

    $Net::SSLeay::trace = 2;

    my $rv = Net::SSLeay::accept($ssl);
    if (!$rv) {
        warn "SSL accept error on $conn\n";
        $conn->close;
        return;
    }

    warn "$conn:  Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n";

    $conn->set_writer_func(DJabberd::Stanza::StartTLS->danga_socket_writerfunc($conn));
}

sub actual_error_on_empty_read {