CasperSecurity

Current Path : /usr/share/doc/libio-socket-ssl-perl/examples/

Upload File :

Current File : //usr/share/doc/libio-socket-ssl-perl/examples/async_https_server.pl

##########################################################
# 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
	}
    } elsif ( $n == 0 ) {
	DEBUG( "connection closed" );
	close($fdc);
    } else {
	# check if we have the whole http header
	my $i = index( $$rbuf_ref,"\r\n\r\n" );   # check \r\n\r\n
	$i = index( $$rbuf_ref,"\n\n" ) if $i<0;  # bad clients send \n\n only
	if ( $i<0 ) {
	    $event->add; # read more from header
	    return;
	}

	# got full header, send request back (we don't serve real pages yet)
	my $header = substr( $$rbuf_ref,0,$i,'' );
	DEBUG( "got header:\n$header" );
	my $wbuf_ref = \${*$fdc}{wbuf};
	$$wbuf_ref = "HTTP/1.0 200 Ok\r\nContent-type: text/plain\r\n\r\n".$header;
	DEBUG( "will send $$wbuf_ref" );
	event_new( $fdc, EV_WRITE, \&_client_write_response )->add;
    }
}

##########################################################
### this is called to write the response to the client
### this will re-add itself as an event as until the full
### response was send
### if it's done it will just close the socket
##########################################################
sub _client_write_response {
    my $event = shift;
    DEBUG( "writing response" );
    my $fdc = $event->fh;
    my $wbuf_ref = \${*$fdc}{wbuf};
    my $n = syswrite( $fdc,$$wbuf_ref );
    if ( !defined($n) && ( $! == EWOULDBLOCK || $! == EAGAIN ) ) {
	# retry
	DEBUG( $SSL_ERROR );
	if ( $SSL_ERROR == SSL_WANT_READ ) {
	    # retry write once we can read
	    event_new( $fdc, EV_READ, \&_client_write_response )->add;
	} else {
	    $event->add; # retry again
	}
    } elsif ( $n == 0 ) {
	DEBUG( "connection closed: $!" );
	close($fdc);
    } else {
	DEBUG( "wrote $n bytes" );
	substr($$wbuf_ref,0,$n,'' );
	if ($$wbuf_ref eq '') {
	    DEBUG( "done" );
	    close($fdc);
	} else {
	    # send more
	    $event->add
	}
    }
}