stress_test_http.pl

#!/usr/bin/perl -w
use strict;
use IO::Socket;
use Time::HiRes qw(time);
my $host = "127.0.0.1";
my $fout;
my $fres;
main();

sub okr2 { return int($_[0] * 100 + 0.5)/100; }
sub s2ms { return okr2( $_[0] * 1000 )}

sub get_multiple_url {
    my $url_base = shift;
    my $url_count = shift;
    my $ret = "";
    foreach my $i ( @$url_count ) {
        my $socket = IO::Socket::INET->new(
                PeerAddr => $host, PeerPort => 80,
                Proto => 'tcp', Timeout => 10, # only connection timeout
                ) or die;
        my $req = "GET http://".$host.$url_base. $i ."\r\n\r\n";
        #warn $req;
        print $socket $req or die $!;
        my $data;
        while(read($socket, $data, 1024) > 0) {
            $ret .= $data;
        }
        die unless defined $data; # at least 1 read
        $socket->close();
    }
    return $ret;
}


sub test
{
    my ($test, $procs, $perproc) = @_;
    # Warm up fcgi and check
    my $url = $test;
    $url = "/cgi/".$url unless $url =~ /\//;
    $url .= "?i=";
    my $r = get_multiple_url($url, [ 0 ]);
    if($r =~ /<title>40[0-9]|404 Not Found|<title>500/) {
        die substr($r, 0, 300);
    }
    return unless $procs and $perproc;
    my @child;
    my $t1 = time;
    for( 1..$procs ) {
        my $pid = fork;
        defined $pid or die $!;
        if($pid) {
            push @child, $pid;
        } else {
            my $r = get_multiple_url($url, [ 1 .. $perproc ]);
            print $fout $r or die $!;
            exit 0;
        }
    }
    foreach ( @child ) {
        waitpid($_,0);
        die "Failed pid ".$_.": ".$? if $?;
    }
    my $t3 = time;
    # 10 exec of curl takes 50ms
    # 10 perl fork takes 2ms
    my $ret = s2ms(($t3 - $t1)/$procs/$perproc);
    my $parsec = int( $procs * $perproc / ($t3 - $t1) + 0.5 );
    my $str = "RES\t".$ret." ms/req x ".$procs." x ".$perproc." = ".s2ms($t3 - $t1)."ms, ".$parsec." req/s\n";
    print $fres $str;
    print $str;
    return $ret;
}

sub test_suite {
    #my (undef, $procs, $perproc) = @_;
    #$procs = 2 unless $procs;
    #$perproc = 2 unless $perproc;

    my @plan = (
                 ["testC",        20, 32,32],
                 ["test0.cgi",    20, 32,32],
                 ["test0.fcgi",   30, 10,10], # 5x5 both pass w/o apache fork and with fork on multi core
                 ["test3000.cgi", 10, 10,10],
                 ["test3000.fcgi",30, 10,10],
                 ["test10000.cgi",10, 10,10],
                 ["test10000.fcgi",30,10,10]
    );
    foreach ( @plan ) {
        my ($test, $repeats, @params) = @$_;
        print $test." ".join(" x ",$repeats, @params)."\n";
        my @res;
        foreach(1..$repeats)
        {
            push @res, test($test, @params);
        }
        my ($avg, $d) = get_avg_deviation(@res);
        my $str = "PLAN ".$test." ".$params[0]."x".$params[1].": ";
        if($d < $avg/4) {
            $str .= "avg=".okr2($avg)." +-".okr2($d)."ms std deviation; ".$repeats." runs: ".join(" ",@res)."\n";
        } else {
            my @reslow  = grep { $_ < $avg } @res;
            my @reshigh = grep { $_ >=$avg } @res;
            my ($avg1,$d1) = get_avg_deviation(@reslow);
            my ($avg2,$d2) = get_avg_deviation(@reshigh);
            $str .= "avgLow=". okr2($avg1)." +-".okr2($d1)."ms for ".scalar(@reslow)." runs; ".
                    "avgHigh=".okr2($avg2)." +-".okr2($d2)."ms for ".scalar(@reshigh)." runs; ".
                    join(" ",@reslow, @reshigh)."\n";
        }
        print $fres $str;
        print $str;
    }
}
sub get_avg_deviation {
    my @res = @_;
    my $avg = 0; map { $avg += $_ } @res; $avg /= @res;
    my $d = 0; map { $d += ($_ - $avg) ** 2 } @res; $d = sqrt($d / @res);
    return ($avg, $d);

    return okr2($avg)." +-".okr2($d)." std deviation; ".scalar(@res)." runs: ".join(" ",@res);
}

sub main {
    die $0." test.cgi proc_num perproc" unless @ARGV > 0;
    my $fname = "test.".$ARGV[0];
    $fname =~ s/\/.*\///;
    mkdir "out";
    -d "out" or die;
    open $fout,">", "out/".$fname.int(time) or die $fname.": ".$!;
    open $fres,">>", $fname.".results" or die $!;

    if($ARGV[0] eq "--test-suite") {
        test_suite();
    } else {
        test(@ARGV);
    }
}