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;
}
$clen = $hdr = undef;
if (!$close) {
my $wb = join('',@wbuf);
if ( $wb =~m{(\r?\n)\1}g) {
$close = _mustclose( substr($wb,0,pos($wb)) );
} else {
$DEBUG && _debug("set close=1 because of no header end in wbuf=$wb");
$close = 1;
}
}
$write->($cl);
return;
} elsif ( $rbuf =~m{(\r?\n)\1}g ) {
# read header
$hdr = substr($rbuf,0,pos($rbuf),'');
my ($line) = $hdr =~m{^([^\r\n]*)};
my $peer = $cl->peerhost;
$peer =~s{^::ffff:}{};
my $urlip;
$line = ungarble_url($line,\$urlip);
$line =~s{\?rand=0\.\d+ }{ }; # remove random for anti-caching
my $ip_mismatch = ($urlip && $urlip ne $peer) ? "| original($urlip)" : "";
(my $method,$page) = $line =~m{ \A
(GET|POST) [\040]+
(/\S*) [\040]+
HTTP/1\.[01] \z
}x or do {
warn localtime()." | $peer | badhdr | $line\n";
push @wbuf,"HTTP/1.0 204 ok\r\n\r\n";
$close = 1;
$write->($cl);
return;
};
if ($page =~m{^/([a-zA-Z0-9_\-]+={0,2})$}) {
# maybe base64
my $data = $1;
$data =~tr{_-}{+/};
$data = eval { decode_base64($data) };
if (! defined $data) {
warn "base64 decode failed: $@";
} elsif ( $data =~m{^(\S+)\0(\d+)\0(.*)\z}s ) {
(my $ref, my $i,$data) = ($1,$2,$3);
my $len = length($data);
$data =~s{\\}{\\\\}g;
$data =~s{\n}{\\n}g;
$data =~s{\r}{\\r}g;
$data =~s{\t}{\\t}g;
printf STDERR "S|%s|%s|%05d|%03d|%s\n",$peer,$ref,$i,$len,$data;
push @wbuf,"HTTP/1.1 200 ok\r\nContent-length: 0\r\n\r\n";
$write->($cl);
return;
} else {
#warn "data have not the right format";
}
}
my $digest = '';
if ($TRACKHDR) {
my $xhdr = $hdr;
$xhdr =~s{\A.*\n}{}; # remove request line
my %KEEPVAL = map { lc($_) => 1 } qw(User-Agent Accept-Encoding Connection Accept Content-type From);
my %KEEPKEY = map { lc($_) => 1 } qw(Host Accept-Language Content-Length);
( my $dhdr = $xhdr ) =~s{^([^\s:]+)(:\s*)(.*(\n[ \t].*)*\n)}{
$KEEPVAL{lc($1)} ? "$1$2$3" : $KEEPKEY{lc($1)} ? "$1$2XXX\r\n" : ""
}emg;
$dhdr = $1.$dhdr if $hdr =~m{^.*(\s+HTTP/1\.[01]\s+)};
my $digest = substr(md5_base64($dhdr),0,8);
$digest =~ tr{+/}{\$%};
if (!$trackhdr{$digest}) {
$trackhdr{$digest} = 1;
my $accept = $xhdr =~m{^Accept:\s*([^\r\n]+)}mi && $1 || '-';
my $ua = $xhdr =~m{^User-Agent:\s*([^\r\n]+)}mi && $1 || 'Unknown-UA';
my @via = $xhdr =~m{^Via:\s*([^\r\n]*)}mig;
$xhdr = $hdr;
$xhdr =~s{\\}{\\\\}g;
$xhdr =~s{\t}{\\t}g;
$xhdr =~s{\r}{\\r}g;
$xhdr =~s{\n}{\\n\n}g;
$xhdr =~s{^}{ |$digest|- }mg;
warn " |$digest|-BEGIN $accept | $ua\n$xhdr";
}
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;