Apache2::Filter::HTTPHeadersFixup - Manipulate Apache 2 HTTP Headers

  # MyApache/FixupInputHTTPHeaders.pm
  package MyApache::FixupInputHTTPHeaders;

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

  use base qw(Apache2::Filter::HTTPHeadersFixup);

  sub manip {
      my ($class, $ra_headers) = @_;

      # modify a header
      for (@$ra_headers) {
          s/^(Foo).*/$1: Moahaha/;
      }

      # push header (don't forget "\n"!)
      push @$ra_headers, "Bar: MidBar\n";
  }
  1;

  # httpd.conf
  <VirtualHost Zoot>
      PerlModule MyApache::FixupInputHTTPHeaders
      PerlInputFilterHandler MyApache::FixupInputHTTPHeaders
  </VirtualHost>

  # similar for output headers

  % t/TEST -trace=debug -v manip/out_append

  APACHE_TEST_TRACE_LEVEL=debug apachectl start

package Apache2::Filter::HTTPHeadersFixup;

$Apache2::Filter::HTTPHeadersFixup::VERSION = '0.06';

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

use mod_perl 1.9917;

use base qw(Apache2::Filter);

use Apache2::Connection ();
use APR::Brigade ();
use APR::Bucket ();

use Apache::TestTrace;

use constant DEBUG => 0;

use subs qw(mydebug);
*mydebug = DEBUG ? \&Apache::TestTrace::debug : sub {};

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

# this is the function that needs to be overriden
sub manip {
    my ($class, $ra_headers) = @_;
    warn "You should write a subclass of " . __PACKAGE__  .
        " since by default HTTP headers are left intact\n";
}

# perl < 5.8 can't handle more than one attribute in the subroutine
# definition so add the "method" attribute separately
use attributes ();
attributes::->import(__PACKAGE__ => \&handler, "method");

sub handler : FilterConnectionHandler {

    mydebug join '', "-" x 20 ,
        (@_ == 6 ? " input" : " output") . " filter called ", "-" x 20;

    # $mode, $block, $readbytes are passed only for input filters
    # so there are 3 more arguments
    return @_ == 6 ? handle_input(@_) : handle_output(@_);

}

sub context {
    my ($f) = shift;

    my $ctx = $f->ctx;
    unless ($ctx) {
        mydebug "filter context init";
        $ctx = {
            headers             => [],
            done_with_headers   => 0,
            seen_body_separator => 0,
            keepalives          => $f->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
        $f->ctx($ctx);
        return $ctx;
    }

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

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

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

    return $ctx;
}

sub handle_output {
    my($class, $f, $bb) = @_;

    my $ctx = context($f);

    # handling the HTTP request body
    if ($ctx->{done_with_headers}) {
        mydebug "passing the body through unmodified";
        my $rv = $f->next->pass_brigade($bb);
        return $rv unless $rv == APR::Const::SUCCESS;
        return Apache2::Const::OK;
    }

    $bb->flatten(my $data);

    mydebug "data: $data\n";

    my $c = $f->c;
    my $ba = $c->bucket_alloc;
    while ($data =~ /(.*\n)/g) {
        my $line = $1;
        mydebug "READ: [$line]";
        if ($line =~ /^[\r\n]+$/) {
            # let the user function do the manipulation of the headers
            # without the separator, which will be added when the
            # manipulation has been completed
            $ctx->{done_with_headers}++;
            $class->manip($ctx->{headers});
            my $data = join '', @{ $ctx->{headers} }, "\n";
            $ctx->{headers} = [];

            my $out_bb = APR::Brigade->new($c->pool, $ba);
            $out_bb->insert_tail(APR::Bucket->new($ba, $data));

            my $rv = $f->next->pass_brigade($out_bb);
            return $rv unless $rv == APR::Const::SUCCESS;

            return Apache2::Const::OK;
            # XXX: is it possible that some data will be along with
            # headers in the same incoming bb?
        }
        else {
            push @{ $ctx->{headers} }, $line;
        }
    }

    return Apache2::Const::OK;
}

sub handle_input {
    my($class, $f, $bb, $mode, $block, $readbytes) = @_;

    my $ctx = context($f);

    # handling the HTTP request body
    if ($ctx->{done_with_headers}) {
        mydebug "passing the body through unmodified";
        return Apache2::Const::DECLINED;
    }

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

    # normal HTTP headers processing
    my $c = $f->c;
    until ($ctx->{seen_body_separator}) {
        my $ctx_bb = APR::Brigade->new($c->pool, $c->bucket_alloc);
        my $rv = $f->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) {
                mydebug "EOS!!!";
                $b->remove;
                $bb->insert_tail($b);
                last;
            }

            my $len = $b->read(my $data);

            # leave the non-data buckets as is
            unless ($len) {
                $b->remove;
                $bb->insert_tail($b);
                next;
            }

            # XXX: losing meta buckets here
            $b->delete;
            mydebug "filter read:\n[$data]";

            if ($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
                mydebug "END of original HTTP Headers";
                $ctx->{seen_body_separator}++;

                # let the user function do the manipulation of the headers
                # without the separator, which will be added when the
                # manipulation has been completed
                $class->manip($ctx->{headers});

                # 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
                push @{ $ctx->{headers} }, "\n";
                mydebug "queued header [$data]";
                inject_header_bucket($bb, $ctx);
                last; # there should be no more headers in $ctx_bb
                # 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 {
                push @{ $ctx->{headers} }, $data;
            }
        }
    }

    return Apache2::Const::OK;
}

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

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

    # extra debug, wasting cycles
    my $data = shift @{ $ctx->{headers} };
    $bb->insert_tail(APR::Bucket->new($bb->bucket_alloc, $data));
    mydebug "injected header: [$data]";

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

    return 1;
}

1;
__END__