File Coverage

blib/lib/Perlbal/Plugin/ForwardedFor.pm

Criterion	Covered	Total	%
statement	21	31	67.7
branch	1	2	50.0
condition			n/a
subroutine	4	8	50.0
pod	3	3	100.0
total	29	44	65.9

package Perlbal::Plugin::ForwardedFor;

use strict;
use warnings;
use Perlbal;

our $VERSION = '0.02';

my $target_header;

sub load {
    Perlbal::register_global_hook( 'manage_command.forwarded_for', sub {
        my $mc = shift->parse(qr/^forwarded_for\s+=\s+(.+)\s*$/,
                  "usage: FORWARDED_FOR = ");

        ($target_header) = $mc->args;

        return $mc->ok;
    } );

    return 1;
}

sub register {
    my ( $self, $svc ) = @_;

    $svc->register_hook(
        'ForwardedFor',
        'backend_client_assigned',
        sub { rewrite_header( @_, $target_header ) },
    );

    return 1;
}

sub rewrite_header {
    my ( $svc, $target_header ) = @_;
    my $headers     = $svc->{'req_headers'};
    my $header_name = 'X-Forwarded-For';
    my $forwarded   = $headers->header($header_name);
    my $DELIMITER   = q{, };
    my $EMPTY       = q{};

    my @ips = split /$DELIMITER/, $forwarded;
    my $ip  = pop @ips;

    $headers->header( $target_header, $ip );

    if (@ips) {
        $headers->header( $header_name, join $DELIMITER, @ips );
    } else {
        # actually, i wish we could delete it
        $headers->header( $header_name, $EMPTY );
    }

    return 0;
}

1;

__END__