root/trunk/lib/Danga/Socket/SSL.pm

package Danga::Socket::SSL;
use strict;
use Danga::Socket 1.54;
use base 'Danga::Socket';
use Net::SSLeay;

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

use constant SSL_ERROR_WANT_READ     => 2;
use constant SSL_ERROR_WANT_WRITE    => 3;

use constant POLLIN        => 1;
use constant POLLOUT       => 4;

use fields (
            'ssl_state',  # our SSL state
            'ssl_write_when_readable',
            );

# optionally override this
sub get_ssl_context {
    my Danga::Socket::SSL $self = shift;

    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,  $self->ssl_private_key_file,
                                             &Net::SSLeay::FILETYPE_PEM);
    Net::SSLeay::die_if_ssl_error("private key");

    Net::SSLeay::CTX_use_certificate_file ($ctx, $self->ssl_cert_file,
                                           &Net::SSLeay::FILETYPE_PEM);
    Net::SSLeay::die_if_ssl_error("certificate");
    return $ctx;
}

# override this:
sub ssl_private_key_file {
    my Danga::Socket::SSL $self = shift;
    return "/dev/null";
}

# override this:
sub ssl_cert_file {
    my Danga::Socket::SSL $self = shift;
    return "/dev/null";
}

sub start_ssl {
    my Danga::Socket::SSL $self = shift;

    my $ctx = $self->get_ssl_context
        or die "No SSL context returned";

    my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");
    $self->{ssl_state} = $ssl;

#    Net::SSLeay::set_verify($ssl, Net::SSLeay::VERIFY_PEER(), 0);

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

    #$Net::SSLeay::trace = 2;
    #Net::SSLeay::connect($ssl) or Net::SSLeay::die_now("Failed SSL connect ($!)");

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

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

    $self->set_writer_func(_danga_socket_writerfunc($self));
}

sub _danga_socket_writerfunc {
    my Danga::Socket::SSL $conn = shift;
    my $ssl = $conn->{ssl_state};
    return sub {
        my ($bref, $to_write, $offset) = @_;

        # unless our event_read has been called, we don't want to try
        # to do any work now.  and probably we should complain.
        if ($conn->{ssl_write_when_readable}) {
            warn "writer func called when we're waiting for readability first.\n";
            return 0;
        }

        # we can't write a lot or we get some SSL non-blocking error.
        # NO LONGER RELEVANT?
        # $to_write = 4096 if $to_write > 4096;

        my $str = substr($$bref, $offset, $to_write);
        my $written = Net::SSLeay::write($ssl, $str);

        if ($written == -1) {
            my $err = Net::SSLeay::get_error($ssl, $written);

            if ($err == SSL_ERROR_WANT_READ) {
                $conn->write_when_readable;
                return 0;
            }
            if ($err == SSL_ERROR_WANT_WRITE) {
                # unclear here.  it just wants to write some more?  okay.
                # easy enough.  do nothing?
                return 0;
            }

            my $errstr = Net::SSLeay::ERR_error_string($err);
            warn " SSL write err = $err, $errstr\n";
            Net::SSLeay::print_errs("SSL_write");
            $conn->close('ssl_write_error');
            return 0;
        }

        return $written;
    };
}

sub is_ssl {
    my Danga::Socket::SSL $self = shift;
    return $self->{ssl_state} ? 1 : 0;
}

# return SSL state object.  more useful as a boolean if conn is in SSL mode.
sub ssl_state {
    my Danga::Socket::SSL $self = shift;
    return $self->{ssl_state};
}

# called by SSL machinery to let us know a write is stalled on readability.
# so we need to (at least temporarily) go readable and then process writes.
sub write_when_readable {
    my $self = shift;

    # enable readability, but remember old value so we can pop it back
    my $prev_readable = ($self->{event_watch} & POLLIN)  ? 1 : 0;
    $self->watch_read(1);
    $self->{ssl_write_when_readable} = [ $prev_readable ];

    # don't need to push/pop its state because Danga::Socket->write, called later,
    # will do the one final write, or if not all written, will turn on watch_write
    $self->watch_write(0);
}

# called by Danga::Socket when a write doesn't fully go through.  by default it
# enables writability.  but we want to do nothing if we're waiting for a read for SSL
sub on_incomplete_write {
    my $self = shift;
    return if $self->{ssl_write_when_readable};
    $self->SUPER::on_incomplete_write;
}

# overloaded read...
sub read {
    my Danga::Socket::SSL $self = $_[0];
    my $amount = $_[1];

    my $ssl = $self->{ssl_state};
    return $self->SUPER::read($amount) unless $ssl;

    my $data = Net::SSLeay::read($ssl);
    my $errs = Net::SSLeay::print_errs('SSL_read');
    if ($errs) {
        warn "SSL Read error: $errs\n";
        $self->close;
        return;
    }

    return undef if defined $data && ! length $data;

    # Net::SSLeays buffers internally, so if we didn't read anything, it's
    # in its buffer
    $data = "" unless $data && length $data;
    return \$data;
}

# if returns true, continue to call event read, else skip event_read.
sub cond_event_read {
    my Danga::Socket::SSL $self = shift;

    # for async SSL:  if a session renegotation is in progress,
    # our previous write wants us to become readable first.
    # we then go back into the write path (by flushing the write
    # buffer) and it then does a read on this socket.
    if (my $ar = $self->{ssl_write_when_readable}) {
        $self->{ssl_write_when_readable} = 0;
        $self->watch_read($ar->[0]);  # restore previous readability state
        $self->watch_write(1);
        return 0;
    }

    $self->event_read;
}


1;