view release on metacpan or  search on metacpan

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

		}
		warn localtime()." |$digest| $peer | $line".($ssl ? " | $ssl":"")."$ip_mismatch\n";
	    } else {
		my $ua = $hdr =~m{^User-Agent:\s*([^\r\n]+)}mi && $1 || 'Unknown-UA';
		my @via = $hdr =~m{^Via:\s*([^\r\n]*)}mig;
		warn localtime()." | $ua  | $peer | $line | @via$ip_mismatch\n";
	    }

	    $clen = $method eq 'POST' && $hdr =~m{^Content-length:[ \t]*(\d+)}mi && $1 || 0;
	    if ($clen > 2**22) {
		warn "request body too large ($clen)";
		delete_client($cl);
		return;
	    }
	    $close = _mustclose($hdr);
	    $page =~s{%([\da-fA-F]{2})}{ chr(hex($1)) }esg; # urldecode
	    goto handle_data;

	} elsif ( length($rbuf)>4096 ) {
	    warn "request header too large";
	    delete_client($cl);
	    return;
	}
    };

    $write = sub {
	my $cl = shift;

	handle_data:
	if ( ! @wbuf ) {
	    # nothing to write
	    if ($rbuf eq '' && $close) {
		# done
		$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);
	}
    }

    for( my $fn=0;$fn<=$maxfn;$fn++ ) {
	defined $timeout[$fn] or next;
	vec($mask[0],$fn,1) or vec($mask[1],$fn,1) or next;
	my ($expire,$cb,@arg) = @{ $timeout[$fn] };
	my $diff = $didit[$fn] + $expire - $now;
	if ($diff>0) {
	    $to = $diff if !defined $to || $diff<$to;
	} else {
	    $DEBUG && _debug("timeout($fn)");
	    $cb->(@arg);
	}
    }


    @tmpmask = @mask;
    $DEBUG && _debug("enter select timeout=".(defined($to) ? $to:'none'));
    my $rv = select($tmpmask[0],$tmpmask[1],undef,$to);
    $DEBUG && _debug("leave select result=$rv");

    $now = gettimeofday();
    die "loop failed: $!" if $rv < 0;
    goto loop if !$rv;

    for my $rw (0,1) {
	for( my $fn=0; $fn<=$maxfn; $fn++) {
	    vec($tmpmask[$rw],$fn,1) or next;
	    $DEBUG && _debug("selected($fn,$rw)");
	    my $sub = $handler[$fn][$rw] or die "no handler";
	    $didit[$fn] = $now;
	    $sub->[0](@{$sub}[1..$#$sub]);
	}
    }
    goto loop;
}

1;