view release on metacpan or  search on metacpan

xt/argument_poison.t  view on Meta::CPAN

# The positive control, run before the real sweep every time: the unguarded
# helpers the round-20 conversion replaced are swapped into every symbol
# table that aliases them, and the same sweep, on a slice, must report leaks
# of each kind it claims to catch. plain_text here also ignores an overloaded
# "", so the overload rerun has something to catch too.
my %LEAKY = (
    plain_text => sub { !defined $_[1] ? '' : ref $_[1] ? overload::StrVal($_[1]) : $_[1] },
    num        => sub { no warnings; 0 + $_[1] },
    real       => sub { no warnings; 0 + $_[1] },
    unix_time  => sub { no warnings; 0 + $_[1] },
    num_list   => sub { no warnings; [ map { 0 + $_ } ref $_[1] eq 'ARRAY' ? @{ $_[1] } : $_[1] ] },
    text_list  => sub { [ map { "$_" } ref $_[1] eq 'ARRAY' ? @{ $_[1] } : $_[1] ] },
    tl_bytes   => sub { MIME::Base64::encode_base64("$_[1]", '') },
    input_file => sub { ref $_[0] ? $_[0] : { '@type' => 'inputFileLocal', path => "$_[0]" } },
    # only definedness, as need() checked before it refused a ref in an id
    # slot: history() then carries the address into the pages it fetches
    # after a reply, which is what proves follow-up requests are checked
    need       => sub { my ($what, @v) = @_; defined or die "required\n" for @v; 1 },
);
{
    my (%saved, $control, $classes, $cdiverge, $ctor, %ccount, %cocount);
    {
        no strict 'refs';
        no warnings 'redefine';
        for my $h (sort keys %LEAKY) {
            for my $pkg ($sw->helper_globs($h)) {
                $saved{"${pkg}::$h"} = \&{"${pkg}::$h"};
                *{"${pkg}::$h"} = $LEAKY{$h};
            }
        }
    }
    my $ok = eval {
        ($control, $classes) = sweep(bare => ['HASH'], wrapped => ['HASH'], first_only => 1,
                                     count => \%ccount,
                                     sites => sub { !$_[0]{added} });
        $cdiverge = overload_sweep(first_only => 1, count => \%cocount);
        $ctor = ctor_sweep(bare => ['HASH'], wrapped => []);
        1;
    };
    my $err = $@;
    {
        no strict 'refs';
        no warnings 'redefine';
        *{$_} = $saved{$_} for keys %saved;
    }
    ok $ok, 'the positive control ran' or diag $err;
    ok !(grep { no strict 'refs'; \&{$_} != $saved{$_} } keys %saved),
        'and every helper it swapped is restored';
    cmp_ok scalar(keys %saved), '>', 50, 'the control swapped the helpers in every mixin';
    my %n = map { $_ => scalar keys %{ $classes->{$_} || {} } }
            qw(stringified address base64 passed-through followup execute);
    cmp_ok $n{stringified}, '>=', 100, "leaky plain_text is caught as a stringified ref at $n{stringified} sites";
    cmp_ok $n{address}, '>=', 150, "leaky num is caught as an address at $n{address} sites";
    cmp_ok $n{base64}, '>=', 2, "leaky tl_bytes is caught as base64 at $n{base64} sites";
    cmp_ok $n{'passed-through'}, '>=', 20, "leaky input_file is caught passing the ref through at $n{'passed-through'} sites";
    cmp_ok $n{execute}, '>=', 1, "a leak in a synchronous execute() request is caught at $n{execute} sites";
    cmp_ok $n{followup}, '>=', 1, "a leak in a request sent only after a reply is caught at $n{followup} sites";
    cmp_ok scalar(keys %$cdiverge), '>=', 50, 'leaky plain_text is caught by the overload rerun at '
        . scalar(keys %$cdiverge) . ' sites';
    my %nc = map { $_ => scalar keys %{ $ctor->{classes}{$_} || {} } } qw(stringified base64);
    cmp_ok $nc{stringified}, '>=', 5, "and in the constructor options and credentials at $nc{stringified} sites";
    cmp_ok $nc{base64}, '>=', 1, "including the base64 encryption key at $nc{base64} sites";
    cmp_ok scalar(keys %{ $ctor->{diverge} }), '>=', 5, 'and the constructor overload rerun at '
        . scalar(keys %{ $ctor->{diverge} }) . ' sites';
    diag sprintf 'positive control: %d poisoned and %d overload calls; %d distinct leaks (%s); %d divergences',
        $ccount{calls} // 0, $cocount{calls} // 0, scalar(keys %$control),
        join(', ', map { "$_ $n{$_}" } sort keys %n), scalar keys %$cdiverge;
}

phase('control');

# the real sweep
my %count;
my $followups_before = $sw->{stat}{followups} // 0;
my ($fail) = sweep(bare => \@BARE, wrapped => \@WRAPPED, count => \%count);
$count{followups} = ($sw->{stat}{followups} // 0) - $followups_before;
phase('sweep');
is scalar(keys %$fail), 0, 'no poisoned argument reaches tdjson as an address, a string form or itself'
    or report($fail);

# the overload rerun: every plain string leaf of a baseline replaced by an
# object that stringifies to it, and the whole capture compared
sub overload_sweep {
    my (%o) = @_;
    my %diverge;
    for my $name (sort keys %base) {
        for my $b (@{ $base{$name} }[0 .. ($o{first_only} ? 0 : $#{ $base{$name} })]) {
            my ($m, $args) = @$b{qw(m args)};
            my $want = ArgumentPoison::canon_wire($b->{res});
            my %optname = map { $_ => 1 } @{ $m->{keys} }, qw(timeout retry);
            my @leaf;
            my $walk;
            $walk = sub {
                my ($v, $path) = @_;
                if (ref $v eq 'ARRAY') {
                    $walk->($v->[$_], [ @$path, $_ ]) for 0 .. $#$v;
                } elsif (ArgumentPoison::is_spec_hash($v)) {
                    $walk->($v->{$_}, [ @$path, "{$_}" ]) for sort keys %$v;
                } elsif (defined $v && !ref $v && $v !~ /\A\s*[+-]?[0-9.]+(?:[eE][+-]?[0-9]+)?\s*\z/) {
                    return if @$path == 1 && $optname{$v} && $path->[0] < $#$args;
                    push @leaf, $path;
                }
            };
            $walk->($args, []);
            undef $walk;
            for my $path (@leaf) {
                my $a = ArgumentPoison::dclone($args);
                ArgumentPoison::set_at($a, $path, ArgumentPoison::Stringy->new(ArgumentPoison::get_at($args, $path)));
                my $res = $sw->invoke($m, $a);
                $o{count}{calls}++;
                next if $res->{err} && $res->{err} =~ /option name must be a string/;
                my $got = ArgumentPoison::canon_wire($res);
                next if !$res->{err} && $got eq $want;
                # a request that embeds the clock can differ from its own rerun
                next if ArgumentPoison::canon_wire($sw->invoke($m, ArgumentPoison::dclone($args))) ne $want;
                my $label = ArgumentPoison::label($path);
                next if $OVERLOAD_OK{$name} && $OVERLOAD_OK{$name}{$label};
                $diverge{"$name $label"} = sprintf "%s: %s", ArgumentPoison::render_call($m, $a),
                    $res->{err} ? 'croaks: ' . (split /\n/, $res->{err})[0]
                                : 'sends ' . ArgumentPoison::trim_wire($got, undef, 200)
                                . ' instead of ' . ArgumentPoison::trim_wire($want, undef, 200);