File Coverage

blib/lib/Net/IMP/Pattern.pm

Criterion	Covered	Total	%
statement	111	136	81.6
branch	55	102	53.9
condition	14	30	46.6
subroutine	12	13	92.3
pod	4	5	80.0
total	196	286	68.5

use strict;
use warnings;
no if $] >= 5.017011, warnings => 'experimental::smartmatch';

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,
    'buftype',  # type of data in buffer
    '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 [ undef, \@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
	buftype => [0,0],    # 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,$offset,$type) = @_;

    $offset and die "cannot deal with gaps in data";

    # if this is the wrong dir return, we already issued PASS
    return if defined $self->{rxdir} and $dir != $self->{rxdir};

    # accumulate results
    my @rv;

    my $buf;
    if ( $type > 0 or $type != $self->{buftype}[$dir] ) {
	# packet data or other streaming type
	$buf = $data;
	if ( $self->{buf}[$dir] ne '' ) {
	    # pass previous buffer and reset it
	    debug("reset buffer because type=$type, buftype=$self->{buftype}[$dir]");
	    $self->{offset}[$dir] += length($self->{buf}[$dir]);
	    $self->{buf}[$dir] = '';
	    push @rv, [ IMP_PASS,$dir,$self->{offset}[$dir] ];
	} elsif ( ! $self->{buftype}[$dir] and not $type > 0 ) {
	    # initial streaming buf
	    $self->{buf}[$dir] = $buf;
	}
	$self->{buftype}[$dir] = $type;
    } else {
	# streaming data, match can span multiple chunks
	$buf = ( $self->{buf}[$dir] .= $data );
    }

    $DEBUG && debug("got %d bytes $type on %d, bufsz=%d, rxlen=%d",
	length($data),$dir,length($buf),$self->{rxlen});

    # for packet types we accumulate datain newdata and set changed if newdata
    # are different from old
    my $changed = 0;
    my $newdata = '';

    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
	    }

	    if ( $good ne '' ) {
		$DEBUG && debug("pass %d bytes in front of match",
		    length($good));
		# pass everything before the match and advance offset
		$self->{offset}[$dir]+=length($good);
		if ( $type>0 ) {
		    # keep good
		    $newdata .= substr($buf,0,length($good),'');
		} else {
		    # pass good
		    push @rv, [ IMP_PASS, $dir, $self->{offset}[$dir] ];
		    substr($buf,0,length($good),'');
		}
	    }
	    # remove match
	    substr($buf,0,length($match),'');
	    $self->{offset}[$dir] += length($match);

	    if ( $match eq '' ) {
		# match got reset 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
		if ( $type > 0 ) {
		    # no need to add nothing to $newdata :)
		    $changed = 1;
		} else {
		    push @rv,[
			IMP_REPLACE,
			$dir,
			$self->{offset}[$dir],
			'',
		    ];
		}
		push @rv,[ IMP_TOSENDER,$dir,$self->{actdata} ]
		    if $self->{actdata} ne '';

	    } elsif ( $self->{action} eq 'replace' ) {
		# forward something else
		if ( $type > 0 ) {
		    $newdata .= $self->{actdata}//'';
		    $changed = 1;
		} else {
		    push @rv,[
			IMP_REPLACE,
			$dir,
			$self->{offset}[$dir],
			$self->{actdata}//''
		    ];
		}

	    } else {
		# should not happen, because action was already checked
		die "invalid action $self->{action}";
	    }

	    last if $buf eq ''; # need more data

	} elsif ( $type > 0 ) {
	    # no matches across packets are allowed
	    $self->{offset}[$dir] += length($buf);
	    $newdata .= $buf if $changed;
	    last;

	} 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");
	    push @rv,[ IMP_PASS,$dir,IMP_MAXOFFSET ];
	    $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 ( $type > 0 ) {
	if ( grep { IMP_DENY == $_->[0] } @rv ) {
	    # leave deny alone
	} elsif ( $changed ) {
	    # replace whole packet
	    push @rv, [ IMP_REPLACE,$dir,$self->{offset}[$dir],$newdata ];
	} else {
	    # pass whole packet
	    push @rv, [ IMP_PASS,$dir,$self->{offset}[$dir] ];
	}
    }

    if ( @rv ) {
	$self->{buf}[$dir] = $buf unless $type > 0; # $buf got changed, put back
	debug("bufsize=".length($self->{buf}[$dir]));
	$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__