name : 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 } } }