view release on metacpan or  search on metacpan

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

sub _response_body_imp {
    my ($self,$data,$changed,$args) = @_;
    my ($callback,@cb_args) = @$args;
    my $eof = _check_eof($self,1);
    $callback->(@cb_args,$data,$eof) if $data ne '' || $eof;
}


sub _check_eof {
    my ($self,$dir) = @_;
    $DEBUG && $self->{request}->xdebug(
	"check eof[%d]  - eof=%d - %s - (pre)pass=%d/%d",
	$dir,$self->{eof}[$dir], _show_buf($self,$dir),
	$self->{prepass}[$dir],
	$self->{pass}[$dir]
    );
    return $self->{eof}[$dir]                    # received eof
	&& ! defined $self->{ibuf}[$dir][0][2]   # no more data in buf
	&& (                                     # (pre)pass til end ok
	    $self->{prepass}[$dir] == IMP_MAXOFFSET
	    || $self->{pass}[$dir] == IMP_MAXOFFSET
	);
}

sub _show_buf {
    my ($self,$dir) = @_;
    return join('|',
	map { ($_->[2]||'none')."($_->[0],+".length($_->[1]).")" } 
	@{ $self->{ibuf}[$dir] }
    );
}



############################################################################
# Websockets, TLS upgrades etc
# if not IMP the forwarding will be done inside this function, otherwise it
# will be done in _in_data_imp, which gets called by IMP callback
############################################################################
sub data {
    my ($self,$dir,$data,@callback) = @_;

    # forward to IMP analyzer
    $self->{eof}[$dir] = 1 if $data eq '';
    _imp_data($self,$dir,$data,0,IMP_DATA_HTTPRQ_CONTENT,
	\&_data_imp,[$dir,@callback]);
}

sub _data_imp {
    my ($self,$data,$changed,$args) = @_;
    my ($dir,$callback,@cb_args) = @$args;
    my $eof = $self->{eof}[$dir] &&          # got eof from server
	! defined $self->{ibuf}[$dir][0][2]; # no more data in ibuf[server]
    $callback->(@cb_args,$dir,$data,$eof) if $data ne '' || $eof;
}



############################################################################
# callback from IMP
# process return types and trigger type specific callbacks on (pre)pass/replace
############################################################################
sub _imp_callback {
    my $self = shift;

    my %fwd; # forwarded data, per dir
    for my $rv (@_) {

	# if the request got closed in between just return
	my $request = $self->{request} or return;

	my $rtype = shift(@$rv);

        # deny further data 
        if ( $rtype == IMP_DENY ) {
            my ($impdir,$msg) = @$rv;
	    $DEBUG && $request->xdebug("got deny($impdir) $msg");
            return $request->deny($msg // 'closed by imp');
	}

        # log some data
        if ( $rtype == IMP_LOG ) {
            my ($impdir,$offset,$len,$level,$msg) = @$rv;
	    $DEBUG && $request->xdebug("got log($impdir,$level) $msg");
	    if ( my $sub = $self->{logsub} ) {
		$sub->($level,$msg,$impdir,$offset,$len)
	    }
	    next;
	}

        # set accounting field
        if ( $rtype == IMP_ACCTFIELD ) {
            my ($key,$value) = @$rv;
	    $DEBUG && $request->xdebug("got acct $key => $value");
            $request->{acct}{$key} = $value;
	    next;
	}

        # (pre)pass data up to offset
        if ( $rtype ~~ [ IMP_PASS, IMP_PREPASS ]) {
	    my ($dir,$offset) = @$rv;
	    $DEBUG && $request->xdebug("got $rtype($dir) off=$offset "._show_buf($self,$dir));

	    if ( $rtype == IMP_PASS ) {
		# ignore pass if it's not better than a previous pass
		if ( $self->{pass}[$dir] == IMP_MAXOFFSET ) {
		    # there is no better thing than IMP_MAXOFFSET
		    next;
		} elsif ( $offset == IMP_MAXOFFSET 
		    or $offset > $self->{ibuf}[$dir][0][0] ) {
		    # we can pass new data
		    $self->{pass}[$dir] = $offset;
		} else {
		    # offset is no better than previous pass
		    next;
		}

	    } else { # IMP_PREPASS
		# ignore prepass if it's not better than a previous pass
		# and a previous prepaself->{ibuf}[1][0]
		if ( $self->{pass}[$dir] == IMP_MAXOFFSET