File Coverage

blib/lib/App/HTTP_Proxy_IMP/IMP.pm

Criterion	Covered	Total	%
statement	52	449	11.5
branch	6	316	1.9
condition	0	127	0.0
subroutine	12	34	35.2
pod	0	9	0.0
total	70	935	7.4

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
	require Net::IMP::Cascade;
	my $cascade = Net::IMP::Cascade->new_factory( parts => [ @factory ])
	    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);
	    # replace or add content-length header
	    $$hdr =~s{^(Content-length:[ \t]*)(\d+)}{$1$size}mi
		|| $$hdr =~s{(\n)}{$1Content-length: $size\r\n};
	    return 1;
	};
    }


    # send data to analyzer.
    # will call back into request on processed data
    _imp_data($self,0,$hdr,0,IMP_DATA_HTTPRQ_HEADER,
	\&_request_header_imp,[ $xhdr,@callback ]);
}


############################################################################
# callback from IMP after passing/replacing the HTTP request header
# will reparse the header if changed and continue in @callback from request
############################################################################
sub _request_header_imp {
    my ($self,$hdr,$changed,$args) = @_;
    my ($xhdr,$callback,@cb_args) = @$args;

    if ( $changed ) {
	# we need to parse the header again and update xhdr
	my ($met,$url,$version,$fields) = $hdr =~m{ \A
	    (\S+)[\040\t]+
	    (\S+)[\040\t]+
	    HTTP/(1\.[01])[\040\t]*
	    \r?\n
	    (.*?\n)
	    \r?\n\Z
	}isx;

	# internal URL are not accepted by the client itself, only from
	# plugin. Set xhdr.internal_url if we see, that IMP plugin rewrote
	# url to internal one and strip internal:// again so that original
	# URL could be logged
	my $internal = $met ne 'CONNECT'
	    && $xhdr->{url} !~m{^internal://}i
	    && $url =~s{^internal://}{}i;

	my %kv;
	my $bad = _parse_hdrfields($fields,\%kv);
	$xhdr = {
	    method => uc($met),
	    version => $version,
	    url => $url,
	    fields => \%kv,
	    $bad ? ( junk => $bad ) :(),
	    $internal ? ( internal_url => 1 ):(),
	};
    }

    # we don't know the content length yet, unless it can be determined by the
    # request method. If we got a (pre)pass until the end of the request body
    # fixup_header will know it and adjust the header
    $xhdr->{content_length} =
	$METHODS_WITHOUT_RQBODY{$xhdr->{method}} ? 0:undef;

    $self->{method} = $xhdr->{method};
    return $callback->(@cb_args,$hdr,$xhdr);
}

############################################################################
# fix request header by setting correct content-length
# returns true if header could be fixed
############################################################################
sub fixup_request_header {
    my ($self,$hdr_ref,%args) = @_;
    my $sub = $self->{fixup_header}[0] or return 1;
    my $ok = $sub->($self,$hdr_ref,%args);
    $self->{fixup_header}[0] = undef if $ok;
    return $ok;
}


############################################################################
# process request body data
# just feed to analyzer and call back into request once done
############################################################################
sub request_body {
    my ($self,$data,@callback) = @_;

    # feed data into IMP
    $self->{eof}[0] = 1 if $data eq '';
    _imp_data($self,0,$data,0,IMP_DATA_HTTPRQ_CONTENT,
	\&_request_body_imp,\@callback );
}

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

############################################################################
# process response header
############################################################################
sub response_header {
    my ($self,$hdr,$xhdr,@callback) = @_;

    # if content is encoded we need to decode it in order to analyze
    # it. For now only set decode to the encoding method, this will
    # be changed to a decoding function once we need it in the body
    if ( my $ce = $xhdr->{fields}{'content-encoding'} ) {
	# the right way would be to extract all encodings and then complain, if
	# there is an encoding we don't support. Instead we just look for the
	# encodings we support
	my %ce = map { lc($_) => 1 } map { m{\b(?:x-)?(gzip|deflate)\b}ig } @$ce;
	$self->{decode}{IMP_DATA_HTTPRQ_CONTENT+0}[1] = join(", ",keys %ce)
	    if %ce;
    }

    # header length is needed in callback
    $xhdr->{header_length} = length($hdr);
    _imp_data($self,1,$hdr,0,IMP_DATA_HTTPRQ_HEADER,
	\&_response_header_imp,[$xhdr,@callback] );
}


############################################################################
# callback after passing/replacing the HTTP response header
# will reparse the header if changed and continue in the request via
# callback
############################################################################
sub _response_header_imp {
    my ($self,$hdr,$changed,$args) = @_;
    my ($xhdr,$callback,@cb_args) = @$args;

    my $orig_clen = $xhdr->{content_length};
    my $orig_hlen = $xhdr->{header_length};

    if ( $changed ) {
	# we need to parse the header again and update xhdr
	my ($version,$code,$reason,$fields) = $hdr =~m{ \A
	    HTTP/(1\.[01])[\040\t]+
	    (\d\d\d)
	    (?:[\040\t]+([^\r\n]*))?
	    \r?\n
	    (.*?\n)
	    \r?\n\Z
	}isx;

	my %kv;
	my $bad = _parse_hdrfields($fields,\%kv);
	$xhdr = {
	    code => $code,
	    version => $version,
	    reason => $reason,
	    fields => \%kv,
	    $bad ? ( junk => $bad ) :(),
	};
    }

    # except for some codes or request methods we don't know the
    # content-length of the body yet
    # in these cases we try in this order
    # - check if we got a (pre)pass for the whole body already
    # - use chunked encoding if client speaks HTTP/1.1
    # - don't specify content-length and close request with connection close

    # we don't change $hdr here because it will be rebuild from fields anyway
    if ( $CODE_WITHOUT_RPBODY{$xhdr->{code}} or $xhdr->{code} < 200 ) {
	$xhdr->{content_length} = 0;
	# better remove them
	delete @{ $xhdr->{fields} }{ qw/ content-length transfer-encoding / };
	goto callback;
    }

    if ( $METHODS_WITHOUT_RPBODY{ $self->{method} } ) {
	$xhdr->{content_length} = 0;
	# keep content-length etc, client might want to peek into it using HEAD
	goto callback;
    }

    # reset infos about content-length
    $xhdr->{content_length} = $xhdr->{chunked} = undef;
    delete @{ $xhdr->{fields} }{ qw/ content-length transfer-encoding / };

    # if we have read the whole body already or at least know, that we will
    # not change anymore data, we could compute the new content-length
    my $clen;
    my $nochange;
    while ( defined $orig_clen ) {
	my $rpsize = $orig_hlen + $orig_clen;

	if ( my $pass = $self->{pass}[1] ) {
	    if ( $pass == IMP_MAXOFFSET or $pass >= $rpsize ) {
		# will not look at and not change body
		$nochange = 1;
		goto compute_clen;
	    }
	}
	if ( my $prepass = $self->{prepass}[1] ) {
	    if ( $prepass == IMP_MAXOFFSET or $prepass >= $rpsize ) {
		# will not change body
		$nochange = 1;
		goto compute_clen;
	    }
	}
	if ($self->{ibuf}[1][0][0] >= $rpsize) { # ibuf[server].base
	    # everything passed thru ibuf
	    goto compute_clen;
	}

	# we still don't know final size
	last;

	compute_clen:
	# bytes in ibuf and outstanding bytes will not be changed, so:
	# new_content_length =
	#  ( total_size - received )             # not yet received
	#  + ( received - ibuf.base )            # still in ibuf
	#  --->
	#  total_size - ibuf.base
	$clen = $rpsize - $self->{ibuf}[1][0][0];

	last;
    }

    if ( $self->{decode}{IMP_DATA_HTTPRQ_CONTENT+0}[1] ) {
	if ( $nochange ) {
	    # we will pass encoded stuff, either no decoding needs to
	    # be done (pass) or we will decode only for the analyzer (prepass)
	    # which will only watch at the content, but not change it
	    $self->{pass_encoded}[1] = 1;

	    my $pass = $self->{pass}[1];
	    if ( $pass and defined $orig_clen and (
		$pass == IMP_MAXOFFSET or
		$pass >= $orig_clen + $orig_hlen )) {
		# no need to decode body
		$self->{decode}{IMP_DATA_HTTPRQ_CONTENT+0}[1] = undef;
	    }
	} else {
	    # content is encoded and inspection wants to see decoded stuff,
	    # which we then will forward too
	    # but decoding might change length
	    $clen = undef;
	    # the content will be delivered decoded
	    delete $xhdr->{fields}{'content-encoding'}
	}
    }
    if ( defined $clen ) {
	$xhdr->{fields}{'content-length'} = [ $clen ];
	$xhdr->{content_length} = $clen;
    }

    callback:
    $callback->(@cb_args,$hdr,$xhdr);
}



############################################################################
# handle response body data
############################################################################
sub response_body {
    my ($self,$data,@callback) = @_;

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

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
		    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 ) {
		return $request->fatal(
		    "replacement cannot span multiple data types")
		    if @$ibuf>1 or $ib0->[2]>0;
		return $request->fatal("cannot replace future data ($rlen>$len0)");
	    } elsif ( $rlen < $len0 ) {
		# replace part of buffer
		return $request->fatal("cannot replace part of packet type")
		    if $ib0->[2]>0;

		# keep rest and update position
		substr( $ib0->[1],0,$rlen,'' ) if $rlen;
		$ib0->[0] += $rlen;
	    } else {
		# remove complete buffer
		if ( @$ibuf>1 ) { # 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->[0] += $len0;
		    $ib0->[1] = '';
		} else {
		    # replace with empty
		    @$ibuf = [ $offset,'' ];
		}
	    }

	    push @{$fwd{$dir}}, [
		1,          # changed
		$newdata,   # new data
		$ib0->[3],  # callback
		$ib0->[4],  # cbargs
	    ];

	    next;
	}
        if ( $rtype ~~ [ IMP_PAUSE, IMP_CONTINUE ] ) {
	    my $dir = shift(@$rv);
	    my $relay = $self->{request}{conn}{relay};
	    if ( $relay and my $fo = $relay->fd($dir)) {
		$fo->mask( r => ($rtype == IMP_PAUSE ? 0:1));
	    }
	    next;
	}

	if ( $rtype == IMP_FATAL ) {
	    $request->fatal(shift(@$rv));
	    next;
	}

	return $request->fatal("unsupported IMP return type: $rtype");
    }

    %fwd or return; # no passes/replacements...

    while ( my ($dir,$fwd) = each %fwd ) {
	while ( my $fw = shift(@$fwd)) {
	    #warn Dumper($fw); use Data::Dumper;
	    my ($changed,$data,$callback,$args) = @$fw;
	    $callback->($self,$data,$changed,$args);
	}
    }
}

############################################################################
# send data to IMP analyzer
# if we had a previous (pre)pass some data can be forwarded immediatly, for
# others we have to wait for the analyzer callback
# returns how many bytes of data are waiting for callback, e.g. 0 if we
# we can pass everything immediately
############################################################################
sub _imp_data {
    my ($self,$dir,$data,$offset,$type,$callback,$args) = @_;
    my $ibuf = $self->{ibuf}[$dir];
    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)
	$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)
	    $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)
	    $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]*  # value
    ((?:\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);
            # value-part -> ' ' + 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 {
	my $data = shift;
	$buf .= $data;

	goto inflate if defined $inflate;

	# read gzip|deflate header
	my $wb;
	my $more = $data eq '' ? undef:''; # need more data if possible
	if ( $typ eq 'gzip' ) {
	    my $hdr_len = 10; # minimum gzip header

	    return $more if length($buf) < $hdr_len;
	    my ($magic,$method,$flags) = unpack('vCC',$buf);
	    if ( $magic != 0x8b1f or $method != Z_DEFLATED or $flags & 0xe0 ) {
		$DEBUG && debug("no valid gzip header. assuming plain text");
		$inflate = ''; # defined but false
		goto inflate;
	    }
	    if ( $flags & 4 ) {
		# skip extra section
		return $more if length($buf) < ($hdr_len+=2);
		$hdr_len += unpack('x10v',$buf);
		return $more if length($buf) < $hdr_len;
	    }
	    if ( $flags & 8 ) {
		# skip filename
		my $o = index($buf,"\0",$hdr_len);
		return $more if $o == -1; # end of filename not found
		$hdr_len = $o+1;
	    }
	    if ( $flags & 16 ) {
		# skip comment
		my $o = index($buf,"\0",$hdr_len);
		return $more if $o == -1; # end of comment not found
		$hdr_len = $o+1;
	    }
	    if ( $flags & 2 ) {
		# skip CRC
		return $more if length($buf) < ($hdr_len+=2);
	    }

	    # remove header
	    substr($buf,0,$hdr_len,'');
	    $gzip_csum = 8; # 8 byte Adler CRC at end
	    $wb = -MAX_WBITS(); # see Compress::Raw::Zlib

	} else {
	    # deflate
	    # according to RFC it should be zlib, but due to the encoding name
	    # often real deflate is used instead
	    # check magic bytes to decide

	    # lets see if it looks like a zlib header
	    # check for CM=8, CMID<=7 in first byte and valid FCHECK in
	    # seconds byte
	    return $more if length($buf)<2;
	    my $magic = unpack('C',substr($buf,0,1));
	    if (
		( $magic & 0b1111 ) == 8                   # CM = 8
		and $magic >> 4 <= 7                       # CMID <= 7
		and unpack('n',substr($buf,0,2)) % 31 == 0 # valid FCHECK
	    ) {
		# looks like zlib header
		$wb = +MAX_WBITS(); # see Compress::Raw::Zlib
	    } else {
		# assume deflate
		$wb = -MAX_WBITS(); # see Compress::Raw::Zlib
	    }
	}

	$inflate = Compress::Raw::Zlib::Inflate->new(
	    -WindowBits => $wb,
	    -AppendOutput => 1,
	    -ConsumeInput => 1
	) or die "cannot create inflation stream";

	inflate:

	return '' if $buf eq '';

	if ( ! $inflate ) {
	    # wrong gzip header: sometimes servers claim to use gzip
	    # if confronted with "Accept-Encoding: identity" but in reality
	    # they send plain text
	    # so consider it plain text and don't decode
	    my $out = $buf;
	    $buf = '';
	    return $out
	}

	my $out = '';
	my $stat = $inflate->inflate(\$buf,\$out);
	if ( $stat == Z_STREAM_END ) {
	    if ( $gzip_csum and length($buf) >= $gzip_csum ) {
		# TODO - check checksum - but what would it help?
		substr($buf,0,$gzip_csum,'');
		$gzip_csum = 0;
	    }
	} elsif ( $stat != Z_OK ) {
	    $DEBUG && debug("decode failed: $stat");
	    return; # error
	}
	return $out
    };
}

1;