view release on metacpan or  search on metacpan

lib/App/DubiousHTTP/TestServer.pm  view on Meta::CPAN

}

# close down properly socket etc if user closes program
$SIG{TERM} = $SIG{INT} = sub { exit(0) };

sub run {
    shift;
    my ($addr,$sslargs,$response) = @_;
    if ($sslargs) {
	# XXX do we need a specific minimal version?
	eval { require IO::Socket::SSL } or
	    die "need IO::Socket::SSL for SSL support";
	$sslargs = eval { IO::Socket::SSL::SSL_Context->new( SSL_server => 1, %$sslargs) }
	    or die "creating SSL context: $@";
    }
    my $srv = $IOCLASS->new( LocalAddr => $addr, Listen => 10, ReuseAddr => 1 )
	or die "listen failed: $!";
    $srv->blocking(0);
    $SELECT->handler($srv,0,sub {
	my $cl = $srv->accept or return;
	if (keys(%clients)>$MAX_CLIENTS) {
	    my @cl = sort { $clients{$a}{time} <=> $clients{$b}{time} } keys %clients;
	    while (@cl>$MAX_CLIENTS) {

lib/App/DubiousHTTP/TestServer.pm  view on Meta::CPAN

	} elsif ($buf eq '') {
	    # closed immediately
	    $DEBUG && _debug("client eof after 0 bytes");
	    delete_client($cl);
	    return;
	}
	# assume GET|POST if only uppercase word characters
	return _install_http($cl,$response) if $buf =~m{^[A-Z]+$};

	# initiate TLS handshake
	if (!IO::Socket::SSL->start_SSL($cl,
	    SSL_startHandshake => 0,
	    SSL_server => 1,
	    SSL_reuse_ctx => $sslctx
	)) {
	    warn "sslify failed: $IO::Socket::SSL::SSL_ERROR";
	    delete_client($cl);
	    return;
	}
	return _install_https($cl,$response);
    });
    $SELECT->mask($cl,0,1);

}

sub _install_https {
    my ($cl,$response) = @_;
    my $handler = sub {
	my $cl = shift;
	if ($cl->accept_SSL) {
	    # handshake finally done
	    return _install_http($cl,$response,'https');
	}
	if ($IO::Socket::SSL::SSL_ERROR == IO::Socket::SSL::SSL_WANT_READ()) {
	    $SELECT->mask($cl, 0 => 1, 1 => 0);
	} elsif ($IO::Socket::SSL::SSL_ERROR == IO::Socket::SSL::SSL_WANT_WRITE()) {
	    $SELECT->mask($cl, 0 => 0, 1 => 1);
	} else {
	    warn "sslify failed: $IO::Socket::SSL::SSL_ERROR";
	    delete_client($cl);
	    return;
	}
    };
    $SELECT->handler($cl, 0 => $handler, 1 => $handler);
    $SELECT->mask($cl, 0 => 1);
}

sub _install_http {
    my ($cl,$response,$ssl) = @_;