tests/fuzzrace.pl

#!/usr/bin/perl
# fuzzrace.pl <host> <port> <user> <pass> <o> <r> <lanes> <iters>
# Logs in, grabs the session csrf token, then forks <lanes> children
# each firing <iters> POST /new-file commits at the SAME branch —
# hammers the CAS update-ref path inside the threaded ASan server.
use strict; use warnings;
use IO::Socket::INET;

my ($host, $port, $user, $pass, $o, $r, $lanes, $iters) = @ARGV;

sub http {
    my ($method, $path, $hdrs, $body) = @_;
    my $s = IO::Socket::INET->new(PeerAddr => "$host:$port",
                                  Proto => 'tcp', Timeout => 5)
        or return undef;
    binmode $s;
    my $q = "$method $path HTTP/1.1\r\nHost: x\r\nConnection: close\r\n"
          . ($hdrs // '');
    $q .= "Content-Length: " . length($body) . "\r\n" if defined $body;
    $q .= "\r\n" . ($body // '');
    print $s $q;
    my $resp = '';
    $resp .= $_ while <$s>;
    close $s;
    return $resp;
}

# login -> session cookie
my $lr = http('POST', '/login', '',
              "name=$user&pass=$pass") // die "login conn fail\n";
my ($sess) = $lr =~ /Set-Cookie: gt_session=([0-9a-f]+)/i;
die "no session cookie\n" unless $sess;
my $ck = "Cookie: gt_session=$sess\r\n";

# csrf from /account
my $ar = http('GET', '/account', $ck) // die "account conn fail\n";
my ($csrf) = $ar =~ /name=csrf value='([0-9a-f]+)'/;
die "no csrf\n" unless $csrf;

my %stat;
for my $lane (1 .. $lanes) {
    my $pid = fork();
    die "fork: $!" unless defined $pid;
    if ($pid == 0) {
        my ($ok, $moved, $other) = (0, 0, 0);
        for my $i (1 .. $iters) {
            my $body = "csrf=$csrf&ref=master&path=race.txt"
                     . "&content=lane$lane-$i";
            my $resp = http('POST', "/$o/$r/new-file", $ck, $body);
            if (!defined $resp) { exit 2; }        # conn fail: server dead?
            elsif ($resp =~ m{^HTTP/1\.1 302})  { $ok++ }
            elsif ($resp =~ /branch moved/)     { $moved++ }
            else {
                $other++;
                my ($code) = $resp =~ m{^HTTP/1\.1 (\d+)};
                warn "lane$lane other: HTTP " . ($code // '?') . "\n";
            }
        }
        print "lane$lane: $ok committed, $moved raced, $other other\n";
        exit 0;
    }
}
my $dead = 0;
while (wait() > 0) {
    $dead++ if $? != 0;
}
exit($dead ? 1 : 0);