view release on metacpan or  search on metacpan

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

use strict;
use warnings;
package App::DubiousHTTP::TestServer;
use Scalar::Util 'weaken';
use Digest::MD5 'md5_base64';
use MIME::Base64 'decode_base64';
use App::DubiousHTTP::Tests::Common qw($TRACKHDR $CLIENTIP ungarble_url);

use IO::Socket::INET;
my $IOCLASS;
BEGIN {
    $IOCLASS = 'IO::Socket::'. ( eval { require IO::Socket::IP } ? 'IP':'INET' );
}

my $MAX_CLIENTS = 100;
my $SELECT = App::DubiousHTTP::TestServer::Select->new;
my %clients;
my $DEBUG = 0;
my %trackhdr;

sub _debug {
    $DEBUG or return;
    my $msg = shift;
    $msg = sprintf($msg,@_) if @_;
    my $time = localtime();
    $msg =~s{^}{DEBUG: $time }mg;
    print STDERR $msg."\n";
}

# 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) {
		my $old = $clients{ shift(@cl) };
		delete_client($old->{fd});
	    }
	}
	$cl->blocking(0);
	add_client($cl,$response,$sslargs);
    });
    $SELECT->mask($srv,0,1);
    $SELECT->loop;
}

sub delete_client {
    my $cl = shift;
    delete $clients{fileno($cl)};
    $SELECT->delete($cl);
}

sub add_client {
    my ($cl,$response,$sslctx) = @_;
    my $addr = $cl->sockhost.':'.$cl->sockport;
    $DEBUG && _debug("new client from $addr");

    $clients{fileno($cl)}{time} = time();
    weaken( my $wcl = $cl );
    $clients{fileno($cl)}{fd} = $wcl;
    $SELECT->timeout($cl,5,sub { delete_client($wcl) if $wcl });

    return _install_check_https($cl,$response,$sslctx) if $sslctx;
    return _install_http($cl,$response);
}

sub _install_check_https {
    my ($cl,$response,$sslctx) = @_;
    $DEBUG && _debug("add handler for checking https");
    $SELECT->handler($cl,0,sub {
	my $cl = shift;
	my $buf;
	$DEBUG && _debug("socket readable - peek");
	if (!defined recv($cl,$buf,2,MSG_PEEK)) {
	    $DEBUG && _debug("peek failed: $!");
	    delete_client($cl);
	    return;
	} 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) = @_;
    
    my ($clen,$hdr,$page,$payload,$close);

    my $write;
    my $rbuf = '';
    my @wbuf;
    my $read = sub {
	my $cl = shift;
	my $n = sysread($cl,$rbuf,8192,length($rbuf));
	$DEBUG && _debug("read on ".fileno($cl)." -> ".(defined $n ? $n : $!));
	if ( !$n ) {
	    # close on eof or error
	    if (defined($n) || ! $!{EAGAIN}) {
		if ($clen) {
		    warn "ERROR: client closed with $clen bytes outstanding";
		    $payload =~s{^}{DATA|}mg;
		    print STDERR $payload;
		}
		delete_client($cl);
	    }
	    return;
	}

	$clients{fileno($cl)}{time} = time();

	handle_data:
	if (defined $clen) {
	    # has header, extract payload
	    if (length($rbuf) > $clen) {
		$payload .= substr($rbuf,0,$clen,'');
		$clen = 0;
	    } else {
		$payload .= $rbuf;
		$clen -= length($rbuf);
		$rbuf = '';
	    }
	    return if $clen>0; # need more

	    my $addr = $cl->sockhost.':'.$cl->sockport;
	    if ( ! eval {
		$CLIENTIP = $cl->peerhost;
		$CLIENTIP =~s{^::ffff:}{};
		push @wbuf,$response->($page,$addr,$hdr,$payload,$ssl);
		$CLIENTIP = undef;
		1;
	    } ) {
		warn "[$page] creating response failed: $@";
		delete_client($cl);
		return;
	    }