view release on metacpan or  search on metacpan

lib/App/HTTP_Proxy_IMP/IMP.pm  view on Meta::CPAN

use strict;
use warnings;

package App::HTTP_Proxy_IMP::IMP;

use Net::Inspect::Debug qw(:DEFAULT $DEBUG);
use Net::IMP::Debug var => \$DEBUG, sub => \&debug;
use Net::IMP qw(:DEFAULT :log);
use Net::IMP::HTTP;
use Scalar::Util 'weaken';
use Hash::Util 'lock_ref_keys';
use Compress::Raw::Zlib;
no warnings 'experimental'; # smartmatch
use Carp;

my %METHODS_RFC2616 = map { ($_,1) } qw( GET HEAD POST PUT DELETE OPTIONS CONNECT TRACE );
my %METHODS_WITHOUT_RQBODY = map { ($_,1) } qw( GET HEAD DELETE CONNECT );
my %METHODS_WITH_RQBODY = map { ($_,1) } qw( POST PUT );
my %CODE_WITHOUT_RPBODY = map { ($_,1) } qw(204 205 304);
my %METHODS_WITHOUT_RPBODY = map { ($_,1) } qw(HEAD);

# we want plugins to suppport the HTTP Request innterface
my $interface = [
    IMP_DATA_HTTPRQ,
    [ 
	IMP_PASS,
	IMP_PREPASS,
	IMP_REPLACE,
	IMP_TOSENDER,
	IMP_DENY,
	IMP_LOG,
	IMP_ACCTFIELD,
	IMP_PAUSE,
	IMP_CONTINUE,
	IMP_FATAL,
    ]
];

sub can_modify {
    return shift->{can_modify};
}

# create a new factory object
sub new_factory {
    my ($class,%args) = @_;
    my @factory;
    for my $module (@{ delete $args{mod} || [] }) {
	if ( ref($module)) {
	    # assume it is already an IMP factory object
	    push @factory, $module;
	    next;
	}

	# --filter mod=args
	my ($mod,$args) = $module =~m{^([a-z][\w:]*)(?:=(.*))?$}i
	    or die "invalid module $module";
	eval "require $mod" or die "cannot load $mod args=$args: $@";
	my %args = $mod->str2cfg($args//'');
	my $factory = $mod->new_factory(%args) 
	    or croak("cannot create Net::IMP factory for $mod");
	$factory = 
	    $factory->get_interface( $interface ) &&
	    $factory->set_interface( $interface )
	    or croak("$mod does not implement the interface supported by us");
	push @factory,$factory;
    }

    @factory or return;
    if (@factory>1) {
	# for cascading filters we need Net::IMP::Cascade

lib/App/HTTP_Proxy_IMP/IMP.pm  view on Meta::CPAN

	    or croak("cannot create Net::IMP::Cascade factory");
	$cascade = $cascade->set_interface( $interface ) or 
	    croak("cascade does not implement the interface supported by us");
	@factory = $cascade;
    }
    my $factory = $factory[0];

    my $self = bless {
	%args,
	imp => $factory, # IMP factory object
	can_modify => 0, # does interface support IMP_REPLACE, IMP_TOSENDER
    }, $class;
    lock_ref_keys($self);

    # update can_modify
    CHKIF: for my $if ( $factory->get_interface ) {
	my ($dt,$rt) = @$if;
	for (@$rt) {
	    $_ ~~ [ IMP_REPLACE, IMP_TOSENDER ] or next;
	    $self->{can_modify} =1;
	    last CHKIF;
	}
    }
	
    return $self;
}

# create a new analyzer based on the factory
sub new_analyzer {
    my ($factory,$request,$meta) = @_;

    my %meta = %$meta;
    # IMP uses different *addr than Net::Inspect, translate
    # [s]ource -> [c]lient, [d]estination -> [s]erver
    $meta{caddr} = delete $meta{saddr};
    $meta{cport} = delete $meta{sport};
    $meta{saddr} = delete $meta{daddr};
    $meta{sport} = delete $meta{dport};

    my $analyzer = $factory->{imp}->new_analyzer( meta => \%meta );

    my $self = bless {
	request => $request, # App::HTTP_Proxy_IMP::Request object
	imp => $analyzer,
	# incoming data, put into analyzer
	# \@list of [ buf_base,buf,type,callback,$cb_arg ] per dir 
	ibuf => [ 
	    [ [0,''] ],
	    [ [0,''] ],
	],  
	pass => [0,0],      # pass allowed up to given offset (per dir)
	prepass => [0,0],   # prepass allowed up to given offset (per dir)
	fixup_header => [], # sub to fixup content-length in header once known
	eof => [0,0],       # got eof in dir ?
	decode => undef,    # decoder for content-encoding decode{type}[dir]
	pass_encoded => undef, # pass body encoded (analyzer will not change body)
	method => undef,    # request method
	logsub => $factory->{logsub},  # how to log IMP_OG
    }, ref($factory);
    lock_ref_keys($self);
    weaken($self->{request});

    # set callback, this might trigger callback immediately if there are 
    # results pending
    weaken( my $wself = $self );
    $analyzer->set_callback( sub { _imp_callback($wself,@_) } );
    return $self;
}


sub request_header {
    my ($self,$hdr,$xhdr,@callback) = @_;
    my $clen = $xhdr->{content_length};

    # new body might change content-length info in request header
    # need to defer sending header until body length is known
    if ( ! $METHODS_WITHOUT_RQBODY{$xhdr->{method}} ) {
	if ( ! defined $clen and $xhdr->{method} ne 'CONNECT') {
	    # length not known -> chunking
	    die "FIXME: chunking request body not yet supported";
	}

	my $hlen = length($hdr);
	$self->{fixup_header}[0] = sub {
	    my ($self,$hdr,%args) = @_;
	    my $size = $args{content};
	    goto fix_clen if defined $size;

	    if ( my $pass = $self->{pass}[0] ) {
		if ( $pass == IMP_MAXOFFSET or $pass >= $hlen + $clen ) {
		    # will not change body
		    goto fix_clen;
		}
	    }
	    if ( my $prepass = $self->{prepass}[0] ) {
		if ( $prepass == IMP_MAXOFFSET or $prepass >= $hlen + $clen ) {
		    # will not change body
		    goto fix_clen;
		}
	    }
	    if ($self->{ibuf}[0][0][0] >= $hlen + $clen) { # ibuf[client].base
		# everything passed thru ibuf
		goto fix_clen;
	    }

	    # need to defer header until all of the body is passed
	    # or replaced, then we know the size
	    return;

	    fix_clen:

	    if (!defined $size) {
		# bytes in ibuf and outstanding bytes will not be changed, so:
		# new_content_length = 
		#  ( orig_clen + orig_hlen - received ) # not yet received
		#  + ( received - ibuf.base )           # still in ibuf
		#  + defered_body.length                # ready to forward
		#  --->
		#  orig_clen + orig_hlen - ibuf.base + defered_body.length
		$size = $clen + $hlen                   # orig_clen + orig_hlen
		    - $self->{ibuf}[0][0][0]            # ibuf.base
		    + $args{defered};                   # defered_body.length
	    }

	    $DEBUG && $self->{request}->xdebug("fixup header with clen=%d",$size);