root/trunk/lib/Perlbal/SocketSSL.pm

# Base class for SSL sockets.
#
# This is a simple class that extends Danga::Socket and contains an IO::Socket::SSL
# for the purpose of allowing non-blocking SSL in Perlbal.
#
# WARNING: this code will break IO::Socket::SSL if you use it in any plugins or
# have custom Perlbal modifications that use it.  you will run into issues.  This
# is because we override the close method to prevent premature closure of the socket,
# so you will end up with the socket not closing properly.
#
# Copyright 2007, Mark Smith <mark@plogs.net>.
#
# This file is licensed under the same terms as Perl itself.

package Perlbal::SocketSSL;

use strict;
use warnings;
no  warnings qw(deprecated);

use Danga::Socket 1.44;
use IO::Socket::SSL 0.98;
use Errno qw( EAGAIN );

use base 'Danga::Socket';
use fields qw( listener create_time );

# magic IO::Socket::SSL crap to make it play nice with us
{
    no strict 'refs';
    no warnings 'redefine';

    # replace IO::Socket::SSL::close with our own code...
    my $orig = *IO::Socket::SSL::close{CODE};
    *IO::Socket::SSL::close = sub {
        my $self = shift()
            or return IO::Socket::SSL::_invalid_object();

        # if we have args, close ourselves (second call!), else don't
        if (exists ${*$self}->{__close_args}) {
            $orig->($self, @{${*$self}->{__close_args}});
        } else {
            ${*$self}->{__close_args} = [ @_ ];
            ${*$self}->{_danga_socket}->close('intercepted_ssl_close');
        }
    };
}

# called: CLASS->new( $sock, $tcplistener )
sub new {
    my Perlbal::SocketSSL $self = shift;
    $self = fields::new( $self ) unless ref $self;

    Perlbal::objctor($self);

    my ($sock, $listener) = @_;

    ${*$sock}->{_danga_socket} = $self;
    $self->{listener} = $listener;
    $self->{create_time} = time;

    $self->SUPER::new($sock);

    # TODO: would be good to have an overall timeout so that we can
    # kill sockets that are open and just sitting there.  "ssl_handshake_timeout"
    # or something like that...

    return $self;
}

# this is nonblocking, it attempts to setup SSL and if it can't then
# it returns whether it needs to read or write.  we then setup to wait
# for the event it indicates and then wait.  when that event fires, we
# call down again, and repeat the process until we have setup the
# SSL connection.
sub try_accept {
    my Perlbal::SocketSSL $self = shift;

    my $sock = $self->{sock}->accept_SSL;

    if (defined $sock) {
        # looks like we got it!  let's steal it from ourselves
        # so Danga::Socket gives up on it and we can send
        # it out to someone else.  (we discard the return value
        # as we already have it in $sock)
        #
        # of course, life isn't as simple as that.  we have to do
        # some trickery with the ordering here to ensure that we
        # don't setup the new class until after the Perlbal::SocketSSL
        # goes away according to Danga::Socket.
        # 
        # if we don't do it this way, we get nasty errors because
        # we (this object) still exists in the DescriptorMap of
        # Danga::Socket when the new Perlbal::ClientXX tries to
        # insert itself there.

        # removes us from the active polling, closes up shop, but
        # save our fd first!
        my $fd = $self->{fd};
        $self->steal_socket;

        # finish blowing us away
        my $ref = Danga::Socket->DescriptorMap();
        delete $ref->{$fd};

        # now stick the new one in
        $self->{listener}->class_new_socket($sock);
        return;
    }

    # nope, let's see if we can continue the process
    if ($! == EAGAIN) {
        if ($SSL_ERROR == SSL_WANT_READ) {
            $self->watch_read(1);
        } elsif ($SSL_ERROR == SSL_WANT_WRITE) {
            $self->watch_write(1);
        } else {
            $self->close('invalid_ssl_state');
        }
    } else {
        $self->close('invalid_ssl_error');
    }
}

sub event_read {
    $_[0]->watch_read(0);
    $_[0]->try_accept;
}

sub event_write {
    $_[0]->watch_write(0);
    $_[0]->try_accept;
}

1;