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;
	}

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

		$DEBUG && _debug("close client because all done and close flag set");
		delete_client($cl);
	    } else {
		$SELECT->mask($cl,1,0);
	    }
	    return;
	} 
	my $n = syswrite($cl,$wbuf[0]);
	$DEBUG && _debug("write on ".fileno($cl)." -> ".(defined $n ? $n : $!));
	if ( ! $n ) {
	    if ( defined($n) || ! $!{EAGAIN} ) {
		# connection broke
		delete_client($cl);
	    } else {
		# try later
		$SELECT->mask($cl,1,1);
	    }
	    return;
	}

	$clients{fileno($cl)}{time} = time();
	substr($wbuf[0],0,$n,'');
	if ($wbuf[0] eq '') {
	    shift @wbuf;
	    if (@wbuf) {
		# delay sending of next packet
		$SELECT->mask($cl,1,0);  # disable write
		$SELECT->timer($cl,1, sub { $write->($cl); });
		return;
	    }
	}
	goto handle_data;
    };

    $SELECT->handler($cl,0,$read,1,$write);
    $SELECT->mask($cl,0,1);
}


sub _mustclose {
    my $hdr = shift;
    my $close;
    my $type = $hdr =~m{^[A-Z]+ /} ? 'request':'response';
    while ($hdr =~m{^Connection:[ \t]*(?:(close)|keep-alive)}mig) {
	$close = $1 ? 1: ($close||-1);
    }
    if ($close) {
	$close = 0 if $close<0;
	$DEBUG && _debug("set close=$close because of connection header in $type");
    } elsif ($hdr =~m{\A(?:.* )?HTTP/1\.(?:0|(1))}) {
	$close = $1 ? 0:1;
	$DEBUG && _debug("set close=$close because of HTTP version in $type");
    } else {
	$close = 1;
	$DEBUG && _debug("set close=$close because no other information are known in $type");
    }
    return $close;
}

package App::DubiousHTTP::TestServer::Select;
use Scalar::Util 'weaken';
use Time::HiRes 'gettimeofday';

my $maxfn = 0;
my @handler;
my @didit;
my @timeout;
my @timer;
my @mask = ('','');
my @tmpmask;
my $now = gettimeofday();
*_debug = \&App::DubiousHTTP::TestServer::_debug;

sub new { bless {},shift }
sub delete {
    my ($self,$cl) = @_;
    defined( my $fn = fileno($cl) ) or die "invalid fd";
    $DEBUG && _debug("remove fd $fn");
    vec($mask[0],$fn,1) = vec($mask[1],$fn,1) = 0;
    vec($tmpmask[0],$fn,1) = vec($tmpmask[1],$fn,1) = 0 if @tmpmask;
    $handler[$fn] = $didit[$fn] = $timeout[$fn] = $timer[$fn] = undef;
    if ($maxfn == $fn) {
	$maxfn-- while ($maxfn>=0 && !$handler[$maxfn]);
    }
}

sub handler {
    my ($self,$cl,%sub) = @_;
    defined( my $fn = fileno($cl) ) or die "invalid fd";
    $maxfn = $fn if $fn>$maxfn;
    weaken(my $wcl = $cl);
    while (my ($rw,$sub) = each %sub) {
	$sub = [ $sub ] if ref($sub) eq 'CODE';
	splice(@$sub,1,0,$wcl);
	$handler[$fn][$rw] = $sub;
	$DEBUG && _debug("add handler($fn,$rw)");
    }
}

sub timer {
    my ($self,$cl,$to,$cb) = @_;
    defined( my $fn = fileno($cl) ) or die "invalid fd";
    ($cb, my @arg) = ref($cb) eq 'CODE' ? ($cb):@$cb;
    push @{ $timer[$fn] }, [ $now+$to,$cb,@arg ];
    @{ $timer[$fn] } = sort { $a->[0] <=> $b->[0] } @{ $timer[$fn] };
}

sub timeout {
    my ($self,$cl,$to,$cb) = @_;
    defined( my $fn = fileno($cl) ) or die "invalid fd";
    if ($to) {
	($cb, my @arg) = ref($cb) eq 'CODE' ? ($cb):@$cb;
	$timeout[$fn] = [ $to,$cb,@arg ];
    } else {
	$timeout[$fn] = undef;
    }
}

sub mask {
    my ($self,$cl,%val) = @_;
    defined( my $fn = fileno($cl) ) or die "invalid fd";
    while (my ($rw,$val) = each %val) {
	$DEBUG && _debug("set mask($fn,$rw) to $val");
	vec($mask[$rw],$fn,1) = $val;
	$didit[$fn] = $now if $val;
    }
}

sub loop {
    my $to;
    loop:

    $to = undef;
    for( my $fn=0;$fn<=$maxfn;$fn++ ) {
	$timer[$fn] or next;
	while (1) {
	    my $t = $timer[$fn][0];
	    if (!$t) {
		$timer[$fn] = undef;
		last;
	    }
	    my ($fire,$cb,@arg) = @$t;
	    if ($fire>$now) {
		# timer in future, update $to
		$to = $fire-$now if !$to || $fire-$now < $to;
		last;
	    }
	    # fire timer now
	    shift(@{$timer[$fn]});
	    $DEBUG && _debug("fire timer($fn)");
	    $cb->(@arg);