# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
package TestPerl::hash_attack;

# if the rehashing of the keys in the stash happens due to the hash attack,
# mod_perl must not fail to find the previously cached stash entry (response
# and fixup handlers in this test). Moreover it must not fail to find
# that entry on the subsequent requests.
#
# the hash attack is detected when HV_MAX_LENGTH_BEFORE_REHASH keys find
# themselves in the same hash bucket on splitting (which happens when the
# number of keys crosses the threshold of a power of 2), in which case
# starting from 5.8.2 the hash will rehash all its keys using a random hash
# seed (PL_new_hash_seed, set in mod_perl or via PERL_HASH_SEED environment
# variable)
#
# Prior to the attack condition hashes use the PL_hash_seed, which is
# always 0.
#
# only in 5.8.1 hashes always use a non-zero PL_hash_seed (unless set
# to 0 via PERL_HASH_SEED environment variable or compiled without
# -DUSE_HASH_SEED or -DUSE_HASH_SEED_EXPLICIT

use strict;
use warnings FATAL => 'all';

use Apache::TestTrace;

use Apache2::Const -compile => 'OK';

use Math::BigInt;

use constant MASK_U32  => 2**32;
use constant HASH_SEED => 0; # 5.8.2: always zero before the rehashing
use constant THRESHOLD => 14; #define HV_MAX_LENGTH_BEFORE_(SPLIT|REHASH)
use constant START     => "a";

# create conditions which will trigger a rehash on the current stash
# (__PACKAGE__::). Relevant for perl 5.8.2 and higher.
sub init {
    my $r = shift;

    no strict 'refs';
    my @attack_keys = attack(\%{__PACKAGE__ . "::"}) if $] >= 5.008002;

    # define a new symbol (sub) after the attack has caused a re-hash
    # check that mod_perl finds that symbol (fixup2) in the stash
    no warnings 'redefine';
    eval qq[sub fixup2 { return Apache2::Const::OK; }];
    $r->push_handlers(PerlFixupHandler => \&fixup2);

    return Apache2::Const::DECLINED;
}

sub fixup { return Apache2::Const::OK; }

sub handler {
    my $r = shift;
    $r->print("ok");
    return Apache2::Const::OK;
}

sub buckets { scalar(%{$_[0]}) =~ m#/([0-9]+)\z# ? 0+$1 : 8 }

sub attack {
    my $stash = shift;

    #require Hash::Util; # avail since 5.8.0
    debug "starting attack (it may take a long time!)";

    my @keys;

    # the minimum of bits required to mount the attack on a hash
    my $min_bits = log(THRESHOLD)/log(2);

    # if the hash has already been populated with a significant amount
    # of entries the number of mask bits can be higher
    my $keys = scalar keys %$stash;
    my $bits = $keys ? log($keys)/log(2) : 0;
    $bits = $min_bits if $min_bits > $bits;

    $bits = ceil($bits);
    # need to add 3 bits to cover the internal split cases
    $bits += 3;
    my $mask = 2**$bits-1;
    debug "mask: $mask ($bits)";

    my $s = START;
    my $c = 0;
    # get 2 keys on top of the THRESHOLD
    my $h;
    while (@keys < THRESHOLD+2) {
        next if exists $stash->{$s};
        $h = hash($s);
        next unless ($h & $mask) == 0;
        $c++;
        $stash->{$s}++;
        debug sprintf "%2d: %5s, %08x %s", $c, $s, $h, scalar(%$stash);
        push @keys, $s;
        debug "The hash collision attack has been successful"
            if Internals::HvREHASH(%$stash);
    } continue {
        $s++;
    }

    # If the rehash hasn't been triggered yet, it's being delayed until the
    # next bucket split.  Add keys until a split occurs.
    unless (Internals::HvREHASH(%$stash)) {
        debug "Will add padding keys until hash split";
        my $old_buckets = buckets($stash);
        while (buckets($stash) == $old_buckets) {
            next if exists $stash->{$s};
            $h = hash($s);
            $c++;
            $stash->{$s}++;
            debug sprintf "%2d: %5s, %08x %s", $c, $s, $h, scalar(%$stash);
            push @keys, $s;
            debug "The hash collision attack has been successful"
                if Internals::HvREHASH(%$stash);
            $s++;
        }
    }

    # this verifies that the attack was mounted successfully. If
    # HvREHASH is on it is. Otherwise the sequence wasn't successful.
    die "Failed to mount the hash collision attack"
        unless Internals::HvREHASH(%$stash);

    debug "ending attack";

    return @keys;
}

# least integer >= n
sub ceil {
    my $value = shift;
    return int($value) < $value ? int($value) + 1 : int($value);
}

# trying to provide the fastest equivalent of C macro's PERL_HASH in
# Perl - the main complication is that the C macro uses U32 integer
# (unsigned int), which we can't do it Perl (it can do I32, with 'use
# integer'). So we outsmart Perl and take modules 2*32 after each
# calculation, emulating overflows that happen in C.
sub hash {
    my $s = shift;
    my @c = split //, $s;
    my $u = HASH_SEED;
    for (@c) {
        # (A % M) + (B % M) == (A + B) % M
        # This works because '+' produces a NV, which is big enough to hold
        # the intermidiate result. We only need the % before any "^" and "&"
        # to get the result in the range for an I32.
        # and << doesn't work on NV, so using 1 << 10
        $u += ord;
        $u += $u * (1 << 10); $u %= MASK_U32;
        $u ^= $u >> 6;
    }
    $u += $u << 3;  $u %= MASK_U32;
    $u ^= $u >> 11; $u %= MASK_U32;
    $u += $u << 15; $u %= MASK_U32;
    $u;
}

# a bit slower but simpler version
sub hash_original {
    my $s = shift;
    my @c = split //, $s;
    my $u = HASH_SEED;
    for (@c) {
        $u += ord;      $u %= MASK_U32;
        $u += $u << 10; $u %= MASK_U32;
        $u ^= $u >> 6;  $u %= MASK_U32;
    }
    $u += $u << 3;  $u %= MASK_U32;
    $u ^= $u >> 11; $u %= MASK_U32;
    $u += $u << 15; $u %= MASK_U32;
    $u;
}

1;

__END__
PerlModule       TestPerl::hash_attack
PerlInitHandler  TestPerl::hash_attack::init
# call twice to verify an access to the same hash value after the rehash
PerlFixupHandler TestPerl::hash_attack::fixup TestPerl::hash_attack::fixup