view release on metacpan or  search on metacpan

example/async_https_server.pl  view on Meta::CPAN

##########################################################
# example HTTPS server using nonblocking sockets
# requires Event::Lib
# at the moment the response consists only of the HTTP
# request, send back as text/plain
##########################################################

use strict;
use IO::Socket;
use IO::Socket::SSL;
use Event::Lib;
use Errno ':POSIX';

#$Net::SSLeay::trace=3;

eval 'use Debug';
*{DEBUG} = sub {} if !defined(&DEBUG);

# create server socket
my $server = IO::Socket::INET->new(
    LocalAddr => '0.0.0.0:9000',
    Listen => 10,
    Reuse => 1,
    Blocking => 0,
) || die $!;

event_new( $server, EV_READ|EV_PERSIST, \&_s_accept )->add();
event_mainloop;

##########################################################
### accept new client on server socket
##########################################################
sub _s_accept {
    my $fds = shift->fh;
    my $fdc = $fds->accept || return;
    DEBUG( "new client" );

    $fdc = IO::Socket::SSL->start_SSL( $fdc,
	SSL_startHandshake => 0,
	SSL_server => 1,
    ) || die $!;

    $fdc->blocking(0);
    _ssl_accept( undef,$fdc );
}

##########################################################
### ssl handshake with client
### called again and again until the handshake is done
### this is called first from _s_accept w/o an event
### and later enters itself as new event until the 
### handshake is done
### if the handshake is done it inits the buffers for the 
### client socket and adds an event for reading the HTTP header
##########################################################
sub _ssl_accept {
    my ($event,$fdc) = @_;
    $fdc ||= $event->fh;
    if ( $fdc->accept_SSL ) {
	DEBUG( "new client ssl handshake done" );
	# setup the client
	${*$fdc}{rbuf} =  ${*$fdc}{wbuf} = '';
	event_new( $fdc, EV_READ, \&_client_read_header )->add;
    } elsif ( $! != EWOULDBLOCK && $! != EAGAIN ) {
	die "new client failed: $!|$SSL_ERROR";
    } else {
	DEBUG( "new client need to retry accept: $SSL_ERROR" );
	my $what = 
	    $SSL_ERROR == SSL_WANT_READ  ? EV_READ  :
	    $SSL_ERROR == SSL_WANT_WRITE ? EV_WRITE :
	    die "unknown error";
	event_new( $fdc, $what,  \&_ssl_accept )->add;
    }
}

    
##########################################################
### read http header
### this will re-add itself as an event until the full
### http header was read
### after reading the header it will setup the response
### which will for now just send the header back as text/plain
##########################################################
sub _client_read_header {
    my $event = shift;
    my $fdc = $event->fh;
    DEBUG( "reading header" );
    my $rbuf_ref = \${*$fdc}{rbuf};
    my $n = sysread( $fdc,$$rbuf_ref,16384,length($$rbuf_ref));
    if ( !defined($n)) {
	die $! if $! != EWOULDBLOCK && $! != EAGAIN;
	DEBUG( $SSL_ERROR );
	if ( $SSL_ERROR == SSL_WANT_WRITE ) {
	    # retry read once I can write
	    event_new( $fdc, EV_WRITE, \&_client_read_header )->add;
	} else {
	    $event->add; # retry
	}