tenbyonethousand.pl

#!/usr/bin/perl
use strict;
use warnings FATAL => qw(all);

# Integration tests Sloop by starting a server, forking a number of clients, and
# sending a volley of requests.  This server runs on port 8181.
# 
# Parameters (all optional):
# 
# - 1st: Number of clients (default 10).
# - 2nd: Number of requests per client (default 1000).
# - 3rd: If defined, will report the server PID to stdout then wait for a
#        HUP signal (`kill -s 1 ...`) before starting.
# 
# The requests alternate between a short HTML page and a larger (~1 MB) binary
# payload.  They are verified by the clients, which will fail and report if a
# mismatch occurs.
# 
# You can set debugging options in this and adapt to whatever
# exploratory/experimental purpose you can dream up.

use LWP::UserAgent;
use Sloop::Server;
use Sloop::Logger;

my $PORT_NO = 8181;
my $LOCALHOST = 'localhost';

# Set parameters.
my $num_clients = 10;
$num_clients = $ARGV[0] if $ARGV[0];
my $num_requests = 1000;
$num_requests = $ARGV[1] if $ARGV[1];
my $tenth = $num_requests / 10;

if (defined $ARGV[2]) {
    print "PID $$...waiting for HUP.\n";
    my $go = 0;
    $SIG{HUP} = sub {
        $go = 1;
    };
    sleep 1 while (!$go);
}

my $page = <<END;
<!DOCTYPE html>
<html>
<body>
      <h1>Hello World</h1>
</body>
</html>
END

# Create a payload for the binary requests.
my ($big, $blen) = randomInput(1234567);
print STDERR "Big payload size: $blen bytes\n";

my $pid = fork;
die "Fork failed: $!" if $pid == -1;

if ($pid) {
# Server is parent.
# Note that starting sloop pre-fork can lead to refused connections.
    # Use /dev/null to discard noisy request logging.
    open my $null, '>', '/dev/null' or die "Could not open /dev/null: $!";
    my $sloop = Sloop::Server->new (
        port => $PORT_NO,
        logger => Sloop::Logger->new(logs=>[\*STDERR, \*STDERR, $null])
    );
    die "\n\nInitialize Sloop::Server failed!\n\n" if (!$sloop);

    $sloop->{handlers} = {
        '/' => sub {
            $_[0]->reply(\$page);
        },
        big => sub {
            $_[0]->reply(\$big, type => 'application/octet-stream');
        },
        # This will trigger shutdown.
        done => sub {
            print STDERR "Server exiting.\n";
            exit 0;
        }
    };
    print STDERR "Server starting...\n";
    $sloop->run;

} else {
# Clients are children.
    sleep 1;
    print STDERR "Starting clients...\n";

    my $n = $num_clients;
    my @pids;
    for (my $i = 0; $i < $n; $i++) {
        $pid = fork;
        if ($pid == -1) { print STDERR "Fork $i failed: $!" }
        elsif (!$pid) {
            clientGo($i);
            $i = $n;
        } else { push @pids, $pid }
    }
    waitpid($_, 0) foreach (@pids);

    # Once the clients are finished, trigger shutdown on the server.
    print STDERR "Clients done.\n";
    my $stop = LWP::UserAgent->new();
    $stop->get("http://$LOCALHOST:$PORT_NO/done", timeout=>1);
}


# Launches an LWP::UserAgent client and sends requests.
sub clientGo {
    my $id = shift;
    my $client = LWP::UserAgent->new();

    my $i = 0;
    for (; $i < $num_requests; $i++) {
        print STDERR "Client $id completed $i requests.\n"
            if $i && !($i % $tenth);
        if ($i % 2) {
            my $reply = $client->get("http://$LOCALHOST:$PORT_NO/");
            reqFail($i, $id, $reply) if $reply->content ne $page;
        } else {
            my $reply = $client->get("http://$LOCALHOST:$PORT_NO/big");
            reqFail($i, $id, $reply) if $reply->content ne $big;
        }
    }

    print STDERR "Client $id completed $i requests.\n";
    exit 0;
}


# Used to report failures.
sub reqFail {
    my ($clientN, $reqN, $resp) = (shift, shift, shift);
    print STDERR "Client $clientN mismatch at $reqN\n";
    my $check = $resp->header("Client-Warning");
    if ($check && $check eq "Internal response") {
    # If you use too many simultaneous clients, you may get
    # "Cannot assign requested address" here.
        print STDERR $resp->content."\n";
    }
    exit 0;
}


# Creates an arbitrary payload.
sub randomInput {
    my $len = shift;
    open my $fh, '<', '/dev/urandom' or die "Could not open /dev/urandom: $!\n";
    my $data;
    my $bytes = read $fh, $data, $len;
    return ($data, $len);
}