158 lines
4.6 KiB
Perl
158 lines
4.6 KiB
Perl
##########################################################
|
|
# 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
|
|
}
|
|
}
|
|
}
|
|
|