use strict;
use warnings;
package Net::IMP::Pattern;
use base 'Net::IMP::Base';
use fields (
'rx', # Regexp from args rx|string
'rxlen', # max size rx can match
'rxdir', # only check this direction
'action', # deny|reject|replace
'actdata', # data for action
'buf', # locally buffered data to match rx, <rxlen and per dir
'offset', # buf[dir][0] is at offset in input stream dir
);
use Net::IMP; # import IMP_ constants
use Net::IMP::Debug;
use Carp 'croak';
sub INTERFACE {
my Net::IMP::Pattern $factory = shift;
my $action = $factory->{factory_args}{action};
my @rv = IMP_PASS;
push @rv,
$action eq 'deny' ? IMP_DENY :
$action eq 'reject' ? (IMP_REPLACE, IMP_TOSENDER) :
$action eq 'replace' ? IMP_REPLACE :
! $action ? IMP_DENY :
croak("invalid action $action");
return [ IMP_DATA_STREAM, \@rv ];
};
sub validate_cfg {
my ($class,%args) = @_;
my @err;
my $rx = delete $args{rx};
my $string = delete $args{string};
my $rxdir = delete $args{rxdir};
if ($rx) {
my $rxlen = delete $args{rxlen};
push @err, "rxlen must be given and >0" unless
$rxlen and $rxlen =~m{^\d+$} and $rxlen>0;
if ( ref($rx) ne 'Regexp' ) {
push @err, "rx must be regex" if ref($rx) ne 'Regexp'
} elsif ( '' =~ $rx ) {
push @err,"rx should not match empty string"
}
}
if ( defined $string ) {
push @err, "only rx or string should be given, not both" if $rx;
} elsif ( ! $rx ) {
push @err, "rx+rxlen or string need to be given for pattern";
}
push @err, "rxdir must be 0|1" if defined $rxdir and not $rxdir ~~ [0,1];
my $act = delete $args{action};
push @err, "action can only be deny|reject|replace" unless
$act and $act ~~ [qw(deny reject replace)];
push @err, "action $act needs actdata" if ! defined(delete $args{actdata});
push @err, $class->SUPER::validate_cfg(%args);
return @err;
}
# create new analyzer object
sub new_analyzer {
my ($factory,%args) = @_;
my $fargs = $factory->{factory_args};
my $rxlen;
my $rx = $fargs->{rx};
if ($rx) {
$rxlen = $fargs->{rxlen};
} else {
$rx = $fargs->{string};
$rxlen = length($rx);
$rx = qr/\Q$rx/;
}
my Net::IMP::Pattern $self = $factory->SUPER::new_analyzer(
%args, # cb, meta
rx => $rx,
rxlen => $rxlen,
rxdir => $fargs->{rxdir},
action => $fargs->{action},
actdata => $fargs->{actdata},
buf => ['',''], # per direction
offset => [0,0], # per direction
);
if ( defined $self->{rxdir} ) {
# if rx is specified only for one direction immediatly issue PASS until
# end for the other direction
$self->run_callback([
IMP_PASS,
$self->{rxdir} ? 0:1,
IMP_MAXOFFSET,
]);
}
return $self;
}
sub data {
my Net::IMP::Pattern $self = shift;
my ($dir,$data) = @_;
# if this is the wrong dir return, we already issued PASS
return if defined $self->{rxdir} and $dir != $self->{rxdir};
my $buf = $self->{buf}[$dir] .= $data;
$DEBUG && debug("got %d bytes on %d, bufsz=%d, rxlen=%d",
length($data),$dir,length($buf),$self->{rxlen});
my @rv;
while (1) {
if ( my ($good,$match) = $buf =~m{\A(.*?)($self->{rx})}s ) {
# rx matched:
# - strip up to end of rx from buf
# - issue IMP_PASS for all data in front of rx
# - handle rx according to action
# - continue with buf after rx (e.g. redo loop)
if ( length($match)> $self->{rxlen} ) {
# user specified a rx, which could match more than rxlen, e.g.
# something like qr{\d+}. make sure we only match rxlen bytes
if ( substr($match,0,$self->{rxlen}) =~m{\A($self->{rx})} ) {
$match = $1;
} else {
# no match possible in rxlen bytes, reset match
# and add one char from original match to $good
# so that we don't try to match here again
$good .= substr($match,0,1);
$match = '';
}
} else {
# we checked in new_analyzer already that rx does not match
# empty string, so we should be save here that rxlen>=match>0
}
# remove up to end of matched data from buf
substr($buf,0,length($good)+length($match),'');
if ( $good ne '' ) {
$DEBUG && debug("pass %d bytes in front of match",
length($good));
# pass everything before the match and advance offset
push @rv, [
IMP_PASS,
$dir,
$self->{offset}[$dir]+=length($good)
]
}
if ( $match eq '' ) {
# match got resetted if >rxlen -> no action
# handle the matched pattern according to action
} elsif ( $self->{action} eq 'deny' ) {
# deny everything after
push @rv,[ IMP_DENY,$dir,$self->{actdata}//'' ];
last; # deny is final
} elsif ( $self->{action} eq 'reject' ) {
# forward nothing, send smthg back to sender
push @rv,[
IMP_REPLACE,
$dir,
$self->{offset}[$dir] += length($match),
''
];
push @rv,[ IMP_TOSENDER,$dir,$self->{actdata} ]
if $self->{actdata} ne '';
} elsif ( $self->{action} eq 'replace' ) {
# forward something else
push @rv,[
IMP_REPLACE,
$dir,
$self->{offset}[$dir] += length($match),
$self->{actdata}//''
];
} else {
# should not happen, because action was already checked
die "invalid action $self->{action}";
}
last if $buf eq ''; # need more data
} elsif ( (my $d = length($buf) - $self->{rxlen} + 1) > 0 ) {
# rx did not match, but >=rxlen bytes in buf:
# we can IMP_PASS some, but rxlen-1 data needs to be kept in buffer
# so that we retry rx when new data come in
$DEBUG && debug("can pass %d of %d bytes",$d,length($buf));
push @rv, [ IMP_PASS, $dir, $self->{offset}[$dir] += $d ];
substr($buf,0,$d,'');
last; # need more data
} elsif ( $data eq '' ) {
# rx did not match, but eof:
# no more data will come which can match rx so we can pass the rest
$DEBUG && debug("pass rest of data on eof");
if ( $buf ne '' ) {
push @rv,[ IMP_PASS,$dir,$self->{offset}[$dir]+=length($buf)];
$buf = '';
}
last; # there will be no more matches because of no data
} else {
# rx did not match, but no eof:
last; # need more data
}
}
if ( @rv ) {
$self->{buf}[$dir] = $buf; # $buf got changed, put back
$self->run_callback(@rv);
} else {
$DEBUG && debug("need more data");
}
}
sub str2cfg {
my ($class,$str) = @_;
my %cfg = $class->SUPER::str2cfg($str);
if ($cfg{rx}) {
$cfg{rx} = eval { qr/$cfg{rx}/ }
|| croak("'$cfg{rx}' is no valid regex");
}
return %cfg;
}
1;
__END__
=head1 NAME
Net::IMP::Pattern - IMP plugin for reacting to matched pattern
=head1 SYNOPSIS
my $factory = Net::IMP::Pattern->new_factory(
rx => qr/this|that/, # pattern
rxlen => 7, # maximum length regex can match
action => 'replace', # 'deny','reject'..
actdata => 'newdata', # replace with newdata
);
=head1 DESCRIPTION
C<Net::IMP::Pattern> implements an analyzer to match regular expressions and
replace or reject the data or cause a deny.
The behavior is specified in the arguments given to C<new_factory> or
C<new_analyzer>.
=over 4
=item rx Regex
The regular expression (as Regexp).
C<rx> should only match up to the number of bytes specified by C<rxlen>, e.g.
regular expressions like C</\d+/> should be avoided, better use C</\d{1,10}/>.
Although it will do its best to only match C<rxlen> in that case, these
kind of broad regular expressions are a sign, that the user does not really
know what should be matched.
Regular expressions which can match the empty buffer, like C</\d*/>, are not
allowed at all and it will croak when trying to use such a regular expression.
=item rxlen Integer
The maximum number of bytes the regex could match or is allowed to match.
This argument is necessary together with C<rx> because there is no way to
determine how many bytes an arbitrary regular expression might match.
=item string String
Instead of giving the regular expression C<rx> together with C<rxlen>, a fixed
string can be given.
=item rxdir 0|1
With this optional argument one can restrict the direction where C<rx> or
C<string> will be applied.
Data in the other direction will pass directly.
=item action String
The following actions are supported
=over 8
=item 'deny'
Causes a deny (e.g. close) of the connection, with the deny message specified in
C<actdata>
=item 'reject'
Rejects the data, e.g. replaces the data with C<''> and sends the string given
in C<actdata> back to the sender.
=item 'replace'
Replaces the data with the string given in C<actdata>
=back
=item actdata String
Meaning depends on C<action>. See there.
=back
=head1 AUTHOR
Steffen Ullrich <sullr@cpan.org>
=head1 COPYRIGHT
Copyright by Steffen Ullrich.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.