File Coverage

blib/lib/Plack/Middleware/ReverseProxyPath.pm

Criterion	Covered	Total	%
statement	36	36	100.0
branch	12	12	100.0
condition	5	7	71.4
subroutine	10	10	100.0
pod	1	1	100.0
total	64	66	96.9

package Plack::Middleware::ReverseProxyPath;

use 5.006;
use strict;
use warnings;
use parent qw(Plack::Middleware);
our $VERSION = '0.04';

sub call {
    my $self = shift;
    my $env = shift;

    if (    $env->{'HTTP_X_FORWARDED_SCRIPT_NAME'}
         || $env->{'HTTP_X_TRAVERSAL_PATH'} ) {

        my $x_script_name    = $env->{'HTTP_X_FORWARDED_SCRIPT_NAME'}   || '';
        my $x_traversal_path = $env->{'HTTP_X_TRAVERSAL_PATH'}          || '';
        my $script_name      = $env->{SCRIPT_NAME};

        # replace $script_name . $path_info
        # prefix of $x_traversal_path with $x_script_name
        if ( length $script_name >= length $x_traversal_path ) {
            $script_name =~ s/^\Q$x_traversal_path\E/$x_script_name/
                or _throw_error(
                    "HTTP_X_TRAVERSAL_PATH: $x_traversal_path\n" .
                    "is not a prefix of \n" .
                    "SCRIPT_NAME: $script_name\n" );
        } else {
            # $x_traversal_path is longer, borrow from path_info
            $x_traversal_path =~ s/^\Q$script_name\E//
                or _throw_error(
                    "SCRIPT_NAME $script_name\n" .
                    "is not a prefix of \n" .
                    "HTTP_X_TRAVERSAL_PATH: $x_traversal_path\n" );
            $script_name = $x_script_name;

            $env->{PATH_INFO} =~ s/^\Q$x_traversal_path\E//
                or _throw_error(
                    "Fragment: $x_traversal_path\n" .
                    "is not a prefix of \n" .
                    "PATH_INFO: $env->{PATH_INFO}\n" .
                    " SCRIPT_NAME: $script_name\n" .
                    " HTTP_X_TRAVERSAL_PATH: $env->{HTTP_X_TRAVERSAL_PATH}\n" );

            # add PSGI required '/' (bad headers w/ trailing / could do it)
            $env->{PATH_INFO} =~ s!^([^/])!/$1!;
        }

        if ( $script_name eq '/' ) { # PSGI doesn't allow '/' only
            $script_name = '';
        }
        $env->{SCRIPT_NAME} = $script_name;

        # don't touch REQUEST_URI, it will continue to refer to the original
    }

    return $self->app->($env);
}

sub _throw_error {
    my ($message) = @_;
    die Plack::Middleware::ReverseProxyPath::Exception->new($message);
}

{
    package Plack::Middleware::ReverseProxyPath::Exception;
    use overload '""' => \&message;
    sub new {
        my ($class, $message) = @_;
        return bless { message => $message }, $class;
    }
    sub code { return 500 }
    sub message { return $_[0]->{message} }
}

1;

__END__