view release on metacpan or  search on metacpan

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

	    } 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
		    or $self->{prepass}[$dir] == IMP_MAXOFFSET ) {
		    # there is no better thing than IMP_MAXOFFSET
		    $DEBUG && debug("new off $offset no better than existing (pre)pass=max");
		    next;
		} elsif ( $offset == IMP_MAXOFFSET
		    or $offset > $self->{ibuf}[$dir][0][0] ) {
		    # we can prepass new data
		    $self->{prepass}[$dir] = $offset;
		    $DEBUG && debug("update prepass with new off $offset");
		} else {
		    # offset is no better than previous pass
		    $DEBUG && debug(
			"new off $offset no better than existing $self->{ibuf}[$dir][0][0]");
		    next;
		}
	    }

	    # collect data up to offset for forwarding
	    # list of [ changed,data,callback,cbarg ]
	    my $fwd  = $fwd{$dir} ||= []; 

	    my $ibuf = $self->{ibuf}[$dir];
	    my $ib0; # top of ibuf, e.g. ibuf[0]

	    while ( @$ibuf ) {
		$ib0 = shift(@$ibuf);
		defined $ib0->[2] or last; # dummy entry with no type

		if ( $offset == IMP_MAXOFFSET ) {
		    # forward this buf and maybe more
		    push @$fwd, [ 0, @{$ib0}[1,3,4] ];
		} else {
		    my $pass = $offset - $ib0->[0];
		    my $len0 = length($ib0->[1]);
		    if ( $pass > $len0 ) {
			# forward this buf and maybe more
			push @$fwd, [ 0, @{$ib0}[1,3,4] ];
		    } elsif ( $pass == $len0 ) {
			# forward this buf, but not more
			push @$fwd, [ 0, @{$ib0}[1,3,4] ];

			# add empty buf if this was the last, this will also
			# trigger resetting pass,prepass below
			if ( @$ibuf ) { # still data in buffer
			} elsif (  $ib0->[2] < 0 ) {
			    # no eof yet and no further data in ibuf 
			    # we might get a replacement at the end of the 
			    # buffer so put emptied buffer back
			    $ib0->[1] = '';
			    push @$ibuf, $ib0;
			} else {
			    push @$ibuf, [ $offset,'' ];
			}
			last;
		    } elsif ( $ib0->[2] < 0 ) {
			# streaming type: 
			# forward part of buf 
			push @$fwd, [
			    0,                            # not changed
			    substr($ib0->[1],0,$pass,''), # data
			    $ib0->[3],                    # callback
			    $ib0->[4],                    # args
			];
			# keep rest in ibuf
			unshift @$ibuf,$ib0;
			$ib0->[0] += $pass;
			last; # nothing more to forward
		    } else {
			# packet type: they need to be processed in total
			return $request->fatal("partial $rtype for $ib0->[2]");
		    }
		}
	    }

	    if ( @$ibuf ) {
		# there are still data in ibuf which cannot get passed,
		# so reset pass, prepass
		$self->{pass}[$dir] = $self->{prepass}[$dir] = 0;
	    } else {
		# add empty buffer containing only current offset based on
		# what we last removed from ibuf
		push @$ibuf, [ $ib0->[0] + length($ib0->[1]),'' ];
	    }

	    next;
	}


        # replace data up to offset
        if ( $rtype ==  IMP_REPLACE ) {
	    my ($dir,$offset,$newdata) = @$rv;
	    $DEBUG && $request->xdebug("got replace($dir) off=$offset data.len=".
		length($newdata));
	    my $ibuf = $self->{ibuf}[$dir];
	    @$ibuf or die "no ibuf";

	    # if there is an active pass|prepass (e.g. pointing to future data)
	    # the data cannot be replaced
	    return $request->fatal(
		"cannot replace data which are said to be passed")
		if $self->{pass}[$dir] or $self->{prepass}[$dir];

	    # we cannot replace future data
	    return $request->fatal('IMP', "cannot use replace with maxoffset")
		if $offset == IMP_MAXOFFSET;

	    # data to replace cannot span different types, so they must be in
	    # the first ibuf
	    my $ib0  = $ibuf->[0];
	    my $rlen = $offset - $ib0->[0];
	    my $len0 = length($ib0->[1]);

	    # some sanity checks
	    if ( $rlen < 0 ) {
		return $request->fatal("cannot replace already passed data");
	    } elsif ( $rlen > $len0 ) {

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

    my $eobuf = $ibuf->[-1][0] + length($ibuf->[-1][1]);

    my $encoded_data;
    if ( my $decode = $self->{decode}{$type+0}[$dir] ) {
	# set up decoder if not set up yet
	if ( ! ref($decode)) {
	    # create function to decode content
	    $self->{decode}{$type+0}[$dir] = $decode = _create_decoder($decode)
		|| return $self->{request}->fatal(
		"cannot decode content-encoding $decode");
	}

	# offsets relates to original stream, but we put the decoded stream
	# into ibuf. And offset>0 means, that we have a gap in the input,
	# which is not allowed, when decoding a stream.
	die "cannot use content decoder with gap in data" if $offset;

	$encoded_data = $data if $self->{pass_encoded}[$dir];
	defined( $data = $decode->($data) )
	    or return $self->{request}->fatal("decoding content failed");
    }

    if ( $offset ) {
	die "offset($offset)<eobuf($eobuf)" if $offset < $eobuf;
	$offset = 0 if $offset == $eobuf;
    }

    my $fwd; # what gets send to analyzer

    my $dlen = length($data);
    my $pass =  $self->{pass}[$dir];
    if ( $pass ) {
	# if pass is set there should be no data in ibuf, e.g. everything
	# before should have been passed
	! $ibuf->[0][2] or die "unexpected data in ibuf";

	if ( $pass == IMP_MAXOFFSET ) {
	    # pass thru w/o analyzing
	    $ibuf->[0][0] += $dlen;
	    $DEBUG && $self->{request}->xdebug("can pass($dir) infinite");
	    return $callback->($self,$encoded_data // $data,0,$args);
	}

	my $canpass = $pass - ( $offset||$eobuf );
	if ( $canpass <= 0 ) {
	    # cannot pass anything, pass should have been reset already
	    die "pass($dir,$pass) must be point into future ($canpass)";
	} elsif ( $canpass >= $dlen) {
	    # can pass everything
	    $ibuf->[0][0] += $dlen;
	    if ( $data eq '' ) {
		# forward eof to analyzer
		$fwd = $data;
		$DEBUG && $self->{request}->xdebug("pass($dir) eof");
		goto SEND2IMP;
	    }
	    $DEBUG && $self->{request}->xdebug(
		"can pass($dir) all: pass($canpass)>=data.len($dlen)");
	    return $callback->($self,$encoded_data // $data,0,$args);
	} elsif ( $type < 0 ) {
	    # can pass part of data, only for streaming types
	    # remove from data what can be passed 
	    die "body might change" if $self->{pass_encoded}[$dir];
	    $ibuf->[0][0] += $canpass;
	    my $passed_data = substr($data,0,$canpass,'');
	    $eobuf += $canpass;
	    $dlen = length($data);
	    $DEBUG && $self->{request}->xdebug(
		"can pass($dir) part: pass($canpass)<data.len($dlen)");
	    $callback->($self,$passed_data,0,$args); # callback but continue
	}
    }

    $fwd = $data; # this must be forwarded to analyzer

    my $prepass = $self->{prepass}[$dir];
    if ( $prepass ) {
	# if prepass is set there should be no data in ibuf, e.g. everything
	# before should have been passed
	! $ibuf->[0][2] or die "unexpected data in ibuf";
	if ( $prepass == IMP_MAXOFFSET ) {
	    # prepass everything
	    $ibuf->[0][0] += $dlen;
	    $DEBUG && $self->{request}->xdebug("can prepass($dir) infinite");
	    $callback->($self,$encoded_data // $data,0,$args); # callback but continue
	    goto SEND2IMP;
	}

	my $canprepass = $prepass - ( $offset||$eobuf );
	if ( $canprepass <= 0 ) {
	    # cannot prepass anything, prepass should have been reset already
	    die "prepass must be point into future";
	} elsif ( $canprepass >= $dlen) {
	    # can prepass everything
	    $ibuf->[0][0] += $dlen;
	    $callback->($self,$encoded_data // $data,0,$args); # callback but continue
	    $DEBUG && $self->{request}->xdebug(
		"can prepass($dir) all: pass($canprepass)>=data.len($dlen)");
	    goto SEND2IMP;
	} elsif ( $type < 0 ) {
	    # can prepass part of data, only for streaming types
	    # remove from data what can be prepassed
	    die "body might change" if $self->{pass_encoded}[$dir];
	    $ibuf->[0][0] += $canprepass;
	    my $passed_data = substr($data,0,$canprepass,'');
	    $eobuf += $canprepass;
	    $dlen = length($data);
	    $DEBUG && $self->{request}->xdebug(
		"can prepass($dir) part: prepass($canprepass)<data.len($dlen)");
	    $callback->($self,$passed_data,0,$args); # callback but continue
	}
    }

    # everything else in $data must be added to buffer
   
    # there can be no gaps inside ibuf because caller is only allowed to
    # pass data which we explicitly allowed
    if ( $offset && $offset > $eobuf ) {
	defined $ibuf->[0][2] and       # we have still data in ibuf!
	    die "there can be no gaps in ibuf";
    }
    if ( ! defined $ibuf->[-1][2] ) {
	# replace buf, because it was empty
	$ibuf->[-1] = [ $offset||$eobuf,$data,$type,$callback,$args ];
    } elsif ( $type < 0 
	and $type == $ibuf->[-1][2] 
	and $callback == $ibuf->[-1][3]
    ) {
	# streaming data, concatinate to existing buf of same type
	$ibuf->[-1][1] .= $data;
    } else {
	# different type or non-streaming data, add new buf
	push @$ibuf,[ $offset||$eobuf,$data,$type,$callback,$args ];
    }
    $DEBUG && $self->{request}->xdebug( "ibuf.length=%d", 
	$ibuf->[-1][0] + length($ibuf->[-1][1]) - $ibuf->[0][0]);

    SEND2IMP:
    $DEBUG && $self->{request}->xdebug("forward(%d) %d bytes type=%s off=%d to analyzer",
	$dir,length($fwd),$type,$offset);
    $self->{imp}->data($dir,$fwd,$offset,$type);
    return length($fwd);
}

#####################################################################
# parse header fields
# taken from Net::Inspect::L7::HTTP (where it got put in by myself)
#####################################################################
my $token = qr{[^()<>@,;:\\"/\[\]?={}\x00-\x20\x7f-\xff]+};
my $token_value_cont = qr{
    ($token):                      # key:
    [\040\t]*([^\r\n]*?)[\040\t]*  # <space>value<space>
    ((?:\r?\n[\040\t][^\r\n]*)*)   # continuation lines
    \r?\n                          # (CR)LF
}x;
sub _parse_hdrfields {
    my ($hdr,$fields) = @_;
    my $bad = '';
    parse:
    while ( $hdr =~m{\G$token_value_cont}gc ) {
        if ($3 eq '') {
            # no continuation line
            push @{$fields->{ lc($1) }},$2;
        } else {
            # with continuation line
            my ($k,$v) = ($1,$2.$3);
            # <space>value-part<space> -> ' ' + value-part
            $v =~s{[\r\n]+[ \t](.*?)[ \t]*}{ $1}g;
            push @{$fields->{ lc($k) }},$v;
        }
    }
    if (pos($hdr)//0 != length($hdr)) {
        # bad line inside
        substr($hdr,0,pos($hdr),'');
        $bad .= $1 if $hdr =~s{\A([^\n]*)\n}{};
        goto parse;
    }
    return $bad;
}

#####################################################################
# create decoder function for gzip|deflate content-encoding
#####################################################################
sub _create_decoder {
    my $typ = shift;
    $typ ~~ [ 'gzip','deflate' ] or return; # not supported

    my $gzip_csum;
    my $buf = '';
    my $inflate;

    return sub {