2_0_13/t/filter/TestFilter/in_bbs_inject_header.pm - mod_perl - Git at Google

 # please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
 package TestFilter::in_bbs_inject_header;

 # this filter demonstrates two things:
 # 1. how to write a filter that will work only on HTTP headers
 # 2. how to inject extra HTTP headers
 #
 # the first task is simple for non-keepalive connections -- as soon as
 # a bucket which matches /^[\r\n]+$/ is read we can store that event
 # in the filter context and simply 'return Apache2::Const::DECLINED on the
 # future invocation, so not to slow things.
 #
 # it becomes much trickier with keepalive connection, since Apache
 # provides no API to tell you whether a new request is coming in. We
 # use $c->keepalives to figure out when a new request is coming in, by
 # comparing the previously stored keepalives count, which gets
 # incremented by Apache when the HTTP response headers are generated.
 #
 #
 # the second task is a bit trickier, as the headers_in core httpd
 # filter is picky and it wants each header to arrive in a separate
 # bucket, and moreover this bucket needs to be in its own brigade.
 # so this test arranges for this to happen.
 #
 # the test shows how to push headers at the end of all headers
 # and in the middle, whichever way you prefer.

 use strict;
 use warnings FATAL => 'all';

 use base qw(Apache2::Filter);

 use Apache2::RequestRec ();
 use Apache2::RequestIO ();
 use Apache2::Connection ();
 use APR::Brigade ();
 use APR::Bucket ();
 use APR::Table ();

 use Apache::TestTrace;

 use TestCommon::Utils ();

 use Apache2::Const -compile => qw(OK DECLINED CONN_KEEPALIVE);
 use APR::Const    -compile => ':common';

 my $header1_key = 'X-My-Protocol';
 my $header1_val = 'POST-IT';

 my %headers = (
     'X-Extra-Header2' => 'Value 2',
     'X-Extra-Header3' => 'Value 3',
 );

 my $request_body = "This body shouldn't be seen by the filter";

 # returns 1 if a bucket with a header was inserted to the $bb's tail,
 # otherwise returns 0 (i.e. if there are no buckets to insert)
 sub inject_header_bucket {
     my ($bb, $ctx) = @_;

     return 0 unless @{ $ctx->{buckets} };

     my $b = shift @{ $ctx->{buckets} };
     $bb->insert_tail($b);

     if (1) {
         # extra debug, wasting cycles
         $b->read(my $data);
         debug "injected header: [$data]";
     }
     else {
         debug "injected header";
     }

     # next filter invocations will bring the request body if any
     if ($ctx->{seen_body_separator} && !@{ $ctx->{buckets} }) {
         $ctx->{done_with_headers}   = 1;
         $ctx->{seen_body_separator} = 0;
     }

     return 1;
 }

 sub context {
     my $filter = shift;

     my $ctx = $filter->ctx;
     my $c   = $filter->c;
     unless ($ctx) {
         debug "filter context init";
         $ctx = {
             buckets             => [],
             done_with_headers   => 0,
             seen_body_separator => 0,
             keepalives          => $c->keepalives,
         };

         # since we are going to manipulate the reference stored in
         # ctx, it's enough to store it only once, we will get the same
         # reference in the following invocations of that filter
         $filter->ctx($ctx);
         return $ctx;
     }

     if ($c->keepalive == Apache2::Const::CONN_KEEPALIVE &&
         $ctx->{done_with_headers} &&
         $c->keepalives > $ctx->{keepalives}) {

         debug "a new request resetting the input filter state";

         $ctx->{buckets}             = [];
         $ctx->{done_with_headers}   = 0;
         $ctx->{seen_body_separator} = 0;
         $ctx->{keepalives} = $c->keepalives;
     }

     return $ctx;

 }

 sub handler : FilterConnectionHandler {
     my ($filter, $bb, $mode, $block, $readbytes) = @_;

     debug join '', "-" x 20 , " input filter called -", "-" x 20;

     my $ctx = context($filter);
     my $c = $filter->c;

     # reset the filter state, we start a new request
     if ($c->keepalive == Apache2::Const::CONN_KEEPALIVE &&
         $ctx->{done_with_headers} && $c->notes->get('reset_request')) {
         debug "a new request resetting the input filter state";
         $c->notes->set('reset_request' => 0);
         $ctx->{buckets} = [];
         $ctx->{seen_body_separator} = 0;
         $ctx->{done_with_headers} = 0;
     }

     # handling the HTTP request body
     if ($ctx->{done_with_headers}) {
         # XXX: when the bug in httpd filter will be fixed all the
         # code in this branch will be replaced with:
         #   $filter->remove;
         #   return Apache2::Const::DECLINED;
         # at the moment (2.0.48) it doesn't work
         # so meanwhile tell the mod_perl filter core to pass-through
         # the brigade unmodified
         debug "passing the body through unmodified";
         return Apache2::Const::DECLINED;
     }

     # any custom HTTP header buckets to inject?
     return Apache2::Const::OK if inject_header_bucket($bb, $ctx);

     # normal HTTP headers processing
     my $ctx_bb = APR::Brigade->new($c->pool, $c->bucket_alloc);
     my $rv = $filter->next->get_brigade($ctx_bb, $mode, $block, $readbytes);
     return $rv unless $rv == APR::Const::SUCCESS;

     while (!$ctx_bb->is_empty) {
         my $b = $ctx_bb->first;

         if ($b->is_eos) {
             debug "EOS!!!";
             $b->remove;
             $bb->insert_tail($b);
             last;
         }

         $b->read(my $data);
         # remove must happen after read, since it may cause split and
         # some new buckets inserted behind - if remove called too
         # early, those buckets will be lost
         $b->remove;
         debug "filter read:\n[$data]";

         # check that we really work only on the headers
         die "This filter should not ever receive the request body, " .
             "but HTTP headers" if ($data||'') eq $request_body;

         if ($data and $data =~ /^POST/) {
             # demonstrate how to add a header while processing other headers
             my $header = "$header1_key: $header1_val\r\n";
             push @{ $ctx->{buckets} }, APR::Bucket->new($c->bucket_alloc, $header);
             debug "queued header [$header]";
         }
         elsif ($data =~ /^[\r\n]+$/) {
             # normally the body will start coming in the next call to
             # get_brigade, so if your filter only wants to work with
             # the headers, it can decline all other invocations if that
             # flag is set. However since in this test we need to send
             # a few extra bucket brigades, we will turn another flag
             # 'done_with_headers' when 'seen_body_separator' is on and
             # all headers were sent out
             debug "END of original HTTP Headers";
             $ctx->{seen_body_separator}++;

             # we hit the headers and body separator, which is a good
             # time to add extra headers:
             for my $key (keys %headers) {
                 my $header = "$key: $headers{$key}\r\n";
                 push @{ $ctx->{buckets} }, APR::Bucket->new($c->bucket_alloc, $header);
                 debug "queued header [$header]";
             }

             # but at the same time we must ensure that the
             # the separator header will be sent as a last header
             # so we send one newly added header and push the separator
             # to the end of the queue
             # XXX: this is broken: the bucket must be set-aside before
             # it can be stashed away (missing $b->setaside wrapper)
             push @{ $ctx->{buckets} }, $b;
             debug "queued header [$data]";
             inject_header_bucket($bb, $ctx);
             next; # inject_header_bucket already called insert_tail
             # notice that if we didn't inject any headers, this will
             # still work ok, as inject_header_bucket will send the
             # separator header which we just pushed to its queue
         }
         else {
             # fall through
         }

         $bb->insert_tail($b);
     }

     return Apache2::Const::OK;
 }

 sub response {
     my $r = shift;

     # propogate the input headers and the input back to the client
     # as we need to do the validations on the client side
     $r->headers_out->set($header1_key =>
                          $r->headers_in->get($header1_key)||'');

     for my $key (sort keys %headers) {
         $r->headers_out->set($key => $r->headers_in->get($key)||'');
     }

     my $data = TestCommon::Utils::read_post($r);
     $r->print($data);

     Apache2::Const::OK;
 }

 1;
 __END__
 <NoAutoConfig>
 <VirtualHost TestFilter::in_bbs_inject_header>
   PerlModule TestFilter::in_bbs_inject_header
   PerlInputFilterHandler TestFilter::in_bbs_inject_header
   <Location /TestFilter__in_bbs_inject_header>
      SetHandler modperl
      PerlResponseHandler TestFilter::in_bbs_inject_header::response
   </Location>
 </VirtualHost>
 </NoAutoConfig>
	# please insert nothing before this line: -- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil --
	package TestFilter::in_bbs_inject_header;

	# this filter demonstrates two things:
	# 1. how to write a filter that will work only on HTTP headers
	# 2. how to inject extra HTTP headers
	#
	# the first task is simple for non-keepalive connections -- as soon as
	# a bucket which matches /^[\r\n]+$/ is read we can store that event
	# in the filter context and simply 'return Apache2::Const::DECLINED on the
	# future invocation, so not to slow things.
	#
	# it becomes much trickier with keepalive connection, since Apache
	# provides no API to tell you whether a new request is coming in. We
	# use $c->keepalives to figure out when a new request is coming in, by
	# comparing the previously stored keepalives count, which gets
	# incremented by Apache when the HTTP response headers are generated.
	#
	#
	# the second task is a bit trickier, as the headers_in core httpd
	# filter is picky and it wants each header to arrive in a separate
	# bucket, and moreover this bucket needs to be in its own brigade.
	# so this test arranges for this to happen.
	#
	# the test shows how to push headers at the end of all headers
	# and in the middle, whichever way you prefer.

	use strict;
	use warnings FATAL => 'all';

	use base qw(Apache2::Filter);

	use Apache2::RequestRec ();
	use Apache2::RequestIO ();
	use Apache2::Connection ();
	use APR::Brigade ();
	use APR::Bucket ();
	use APR::Table ();

	use Apache::TestTrace;

	use TestCommon::Utils ();

	use Apache2::Const -compile => qw(OK DECLINED CONN_KEEPALIVE);
	use APR::Const -compile => ':common';

	my $header1_key = 'X-My-Protocol';
	my $header1_val = 'POST-IT';

	my %headers = (
	'X-Extra-Header2' => 'Value 2',
	'X-Extra-Header3' => 'Value 3',
	);

	my $request_body = "This body shouldn't be seen by the filter";

	# returns 1 if a bucket with a header was inserted to the $bb's tail,
	# otherwise returns 0 (i.e. if there are no buckets to insert)
	sub inject_header_bucket {
	my ($bb, $ctx) = @_;

	return 0 unless @{ $ctx->{buckets} };

	my $b = shift @{ $ctx->{buckets} };
	$bb->insert_tail($b);

	if (1) {
	# extra debug, wasting cycles
	$b->read(my $data);
	debug "injected header: [$data]";
	}
	else {
	debug "injected header";
	}

	# next filter invocations will bring the request body if any
	if ($ctx->{seen_body_separator} && !@{ $ctx->{buckets} }) {
	$ctx->{done_with_headers} = 1;
	$ctx->{seen_body_separator} = 0;
	}

	return 1;
	}

	sub context {
	my $filter = shift;

	my $ctx = $filter->ctx;
	my $c = $filter->c;
	unless ($ctx) {
	debug "filter context init";
	$ctx = {
	buckets => [],
	done_with_headers => 0,
	seen_body_separator => 0,
	keepalives => $c->keepalives,
	};

	# since we are going to manipulate the reference stored in
	# ctx, it's enough to store it only once, we will get the same
	# reference in the following invocations of that filter
	$filter->ctx($ctx);
	return $ctx;
	}

	if ($c->keepalive == Apache2::Const::CONN_KEEPALIVE &&
	$ctx->{done_with_headers} &&
	$c->keepalives > $ctx->{keepalives}) {

	debug "a new request resetting the input filter state";

	$ctx->{buckets} = [];
	$ctx->{done_with_headers} = 0;
	$ctx->{seen_body_separator} = 0;
	$ctx->{keepalives} = $c->keepalives;
	}

	return $ctx;

	}

	sub handler : FilterConnectionHandler {
	my ($filter, $bb, $mode, $block, $readbytes) = @_;

	debug join '', "-" x 20 , " input filter called -", "-" x 20;

	my $ctx = context($filter);
	my $c = $filter->c;

	# reset the filter state, we start a new request
	if ($c->keepalive == Apache2::Const::CONN_KEEPALIVE &&
	$ctx->{done_with_headers} && $c->notes->get('reset_request')) {
	debug "a new request resetting the input filter state";
	$c->notes->set('reset_request' => 0);
	$ctx->{buckets} = [];
	$ctx->{seen_body_separator} = 0;
	$ctx->{done_with_headers} = 0;
	}

	# handling the HTTP request body
	if ($ctx->{done_with_headers}) {
	# XXX: when the bug in httpd filter will be fixed all the
	# code in this branch will be replaced with:
	# $filter->remove;
	# return Apache2::Const::DECLINED;
	# at the moment (2.0.48) it doesn't work
	# so meanwhile tell the mod_perl filter core to pass-through
	# the brigade unmodified
	debug "passing the body through unmodified";
	return Apache2::Const::DECLINED;
	}

	# any custom HTTP header buckets to inject?
	return Apache2::Const::OK if inject_header_bucket($bb, $ctx);

	# normal HTTP headers processing
	my $ctx_bb = APR::Brigade->new($c->pool, $c->bucket_alloc);
	my $rv = $filter->next->get_brigade($ctx_bb, $mode, $block, $readbytes);
	return $rv unless $rv == APR::Const::SUCCESS;

	while (!$ctx_bb->is_empty) {
	my $b = $ctx_bb->first;

	if ($b->is_eos) {
	debug "EOS!!!";
	$b->remove;
	$bb->insert_tail($b);
	last;
	}

	$b->read(my $data);
	# remove must happen after read, since it may cause split and
	# some new buckets inserted behind - if remove called too
	# early, those buckets will be lost
	$b->remove;
	debug "filter read:\n[$data]";

	# check that we really work only on the headers
	die "This filter should not ever receive the request body, " .
	"but HTTP headers" if ($data\|\|'') eq $request_body;

	if ($data and $data =~ /^POST/) {
	# demonstrate how to add a header while processing other headers
	my $header = "$header1_key: $header1_val\r\n";
	push @{ $ctx->{buckets} }, APR::Bucket->new($c->bucket_alloc, $header);
	debug "queued header [$header]";
	}
	elsif ($data =~ /^[\r\n]+$/) {
	# normally the body will start coming in the next call to
	# get_brigade, so if your filter only wants to work with
	# the headers, it can decline all other invocations if that
	# flag is set. However since in this test we need to send
	# a few extra bucket brigades, we will turn another flag
	# 'done_with_headers' when 'seen_body_separator' is on and
	# all headers were sent out
	debug "END of original HTTP Headers";
	$ctx->{seen_body_separator}++;

	# we hit the headers and body separator, which is a good
	# time to add extra headers:
	for my $key (keys %headers) {
	my $header = "$key: $headers{$key}\r\n";
	push @{ $ctx->{buckets} }, APR::Bucket->new($c->bucket_alloc, $header);
	debug "queued header [$header]";
	}

	# but at the same time we must ensure that the
	# the separator header will be sent as a last header
	# so we send one newly added header and push the separator
	# to the end of the queue
	# XXX: this is broken: the bucket must be set-aside before
	# it can be stashed away (missing $b->setaside wrapper)
	push @{ $ctx->{buckets} }, $b;
	debug "queued header [$data]";
	inject_header_bucket($bb, $ctx);
	next; # inject_header_bucket already called insert_tail
	# notice that if we didn't inject any headers, this will
	# still work ok, as inject_header_bucket will send the
	# separator header which we just pushed to its queue
	}
	else {
	# fall through
	}

	$bb->insert_tail($b);
	}

	return Apache2::Const::OK;
	}

	sub response {
	my $r = shift;

	# propogate the input headers and the input back to the client
	# as we need to do the validations on the client side
	$r->headers_out->set($header1_key =>
	$r->headers_in->get($header1_key)\|\|'');

	for my $key (sort keys %headers) {
	$r->headers_out->set($key => $r->headers_in->get($key)\|\|'');
	}

	my $data = TestCommon::Utils::read_post($r);
	$r->print($data);

	Apache2::Const::OK;
	}

	1;
	__END__
	<NoAutoConfig>
	<VirtualHost TestFilter::in_bbs_inject_header>
	PerlModule TestFilter::in_bbs_inject_header
	PerlInputFilterHandler TestFilter::in_bbs_inject_header
	<Location /TestFilter__in_bbs_inject_header>
	SetHandler modperl
	PerlResponseHandler TestFilter::in_bbs_inject_header::response
	</Location>
	</VirtualHost>
	</NoAutoConfig>