view release on metacpan or  search on metacpan

lib/CGI/IDS/Whitelist.pm  view on Meta::CPAN

                foreach my $condition (@{$self->{whitelist}{$key}->{conditions}}) {
                    if (! defined($request->{$condition->{key}}) ||
                        ( defined ($condition->{rule}) && $request->{$condition->{key}} !~ $condition->{rule} )
                    ) {
                        $condition_mismatch = 1;
                    }
                }

                # Apply filters if key is not in whitelisted environment conditions
                # or if the value does not match the whitelist rule if one is set.
                # Filtering is skipped if no rule is set.
                if ( $condition_mismatch ||
                    (defined($self->{whitelist}{$key}->{rule}) &&
                    $request_value !~ $self->{whitelist}{$key}->{rule}) ||
                    $contains_encoding
                ) {
                    # apply filters to value, whitelist rules mismatched
                    my $reason = '';
                    if ($condition_mismatch) {
                        $reason = 'cond'; # condition mismatch
                    }
                    elsif (!$contains_encoding) {
                        $reason = 'rule'; # rule mismatch
                    }
                    else {
                        $reason = 'enc'; # contains encoding
                    }
                    push (@{$self->{suspicious_keys}}, {key => $key, value => $request_value, reason => $reason});
                    return 1;
                }
                else {
                    # skipped, whitelist rule matched
                    push (@{$self->{non_suspicious_keys}}, {key => $key, value => $request_value, reason => 'r&c'}); # rule & conditions matched
                }
            }
        }
        else {
            # skipped, harmless string
            push (@{$self->{non_suspicious_keys}}, {key => $key, value => $request_value, reason => 'harml'}); # harmless
        }
    }
    else {
        # skipped, empty value or key generally whitelisted
        my $reason = $request_value ? 'key' : 'empty';
        push (@{$self->{non_suspicious_keys}}, {key => $key, value => $request_value, reason => $reason});
    }
    return 0;
}

#****m* IDS/Whitelist/convert_if_marked_encoded
# NAME
#   convert_if_marked_encoded
# DESCRIPTION
#   Tries to JSON-decode and flatten a value to a plain string if the key has been marked as JSON in the whitelist.
#   Other encodings may follow in future.
# INPUT
#   HASHREF
#     + key
#     + value
# OUTPUT
#   The JSON-decoded and flattened 'value' if key is marked JSON. Plain keys and values, newline separated.
#   Untouched 'value' otherwise.
# SYNOPSIS
#   $whitelist->convert_if_marked_encoded( key => 'data', value = '{"a":"b","c":["123", 111, "456"]}');
#****

=head2 convert_if_marked_encoded()

 DESCRIPTION
   Tries to JSON-decode and flatten a value to a plain string if the key has been marked as JSON in the whitelist.
   Other encodings may follow in future.
 INPUT
   HASHREF
     + key
     + value
 OUTPUT
   The JSON-decoded and flattened 'value' if key is marked JSON. Plain keys and values, newline separated.
   Untouched 'value' otherwise.
 SYNOPSIS
   $whitelist->convert_if_marked_encoded( key => 'data', value => '{"a":"b","c":["123", 111, "456"]}');

=cut

sub convert_if_marked_encoded {
    my ($self, %args)   = @_;
    my $key             = $args{key};
    my $request_value   = $args{value};

    # If marked as JSON, try to convert from JSON to reduce false positives
    if (defined($self->{whitelist}{$key}) &&
        defined($self->{whitelist}{$key}->{encoding}) &&
        $self->{whitelist}{$key}->{encoding} eq 'json') {

        $request_value = _json_to_string($request_value);
    }
    return $request_value;
}

#****m* IDS/Whitelist/suspicious_keys
# NAME
#   suspicious_keys
# DESCRIPTION
#   Returns the set of filters that are suspicious
#   Keys are listed from the last reset() or Whitelist->new()
# INPUT
#   none
# OUTPUT
#   [ { 'value' => , 'reason' => , 'key' =>  }, { ... } ]
# SYNOPSIS
#   $whitelist->suspicious_keys();
#****

=head2 suspicious_keys()

 DESCRIPTION
   Returns the set of filters that are suspicious
   Keys are listed from the last reset() or Whitelist->new()
 INPUT
   none
 OUTPUT
   [ { 'value' => , 'reason' => , 'key' =>  }, { ... } ]
 SYNOPSIS
   $whitelist->suspicious_keys();

=cut

sub suspicious_keys {
    my ($self) = @_;
    return $self->{suspicious_keys};
}

#****m* IDS/Whitelist/non_suspicious_keys
# NAME
#   non_suspicious_keys
# DESCRIPTION
#   Returns the set of filters that have been checked but are not suspicious
#   Keys are listed from the last reset() or Whitelist->new()