File Coverage

blib/lib/Plack/Middleware/ReverseProxyPath.pm
Criterion Covered Total %
statement 34 34 100.0
branch 12 12 100.0
condition 6 7 85.7
subroutine 9 9 100.0
pod 1 1 100.0
total 62 63 98.4


line stmt bran cond sub pod time code
1             package Plack::Middleware::ReverseProxyPath;
2              
3 3     3   619660 use strict;
  3         6  
  3         555  
4 3     3   19 use warnings;
  3         8  
  3         111  
5 3     3   1253 use parent qw(Plack::Middleware);
  3         1750  
  3         24  
6             our $VERSION = '0.03';
7              
8             sub call {
9 44     44 1 306255 my $self = shift;
10 44         90 my $env = shift;
11              
12 44 100 100     252 if ( $env->{'HTTP_X_FORWARDED_SCRIPT_NAME'}
13             || $env->{'HTTP_X_TRAVERSAL_PATH'} ) {
14              
15 36   100     138 my $x_script_name = $env->{'HTTP_X_FORWARDED_SCRIPT_NAME'} || '';
16 36   50     211 my $x_traversal_path = $env->{'HTTP_X_TRAVERSAL_PATH'} || '';
17 36         66 my $script_name = $env->{SCRIPT_NAME};
18              
19             # replace $script_name . $path_info
20             # prefix of $x_traversal_path with $x_script_name
21 36 100       91 if ( length $script_name >= length $x_traversal_path ) {
22 20 100       485 $script_name =~ s/^\Q$x_traversal_path\E/$x_script_name/
23             or _throw_error(
24             "HTTP_X_TRAVERSAL_PATH: $x_traversal_path\n" .
25             "is not a prefix of \n" .
26             "SCRIPT_NAME: $script_name\n" );
27             } else {
28             # $x_traversal_path is longer, borrow from path_info
29 16 100       337 $x_traversal_path =~ s/^\Q$script_name\E//
30             or _throw_error(
31             "SCRIPT_NAME $script_name\n" .
32             "is not a prefix of \n" .
33             "HTTP_X_TRAVERSAL_PATH: $x_traversal_path\n" );
34 15         32 $script_name = $x_script_name;
35              
36 15 100       223 $env->{PATH_INFO} =~ s/^\Q$x_traversal_path\E//
37             or _throw_error(
38             "Fragment: $x_traversal_path\n" .
39             "is not a prefix of \n" .
40             "PATH_INFO: $env->{PATH_INFO}\n" .
41             " SCRIPT_NAME: $script_name\n" .
42             " HTTP_X_TRAVERSAL_PATH: $env->{HTTP_X_TRAVERSAL_PATH}\n" );
43              
44             # add PSGI required '/' (bad headers w/ trailing / could do it)
45 12         48 $env->{PATH_INFO} =~ s!^([^/])!/$1!;
46             }
47              
48 29 100       87 if ( $script_name eq '/' ) { # PSGI doesn't allow '/' only
49 6         10 $script_name = '';
50             }
51 29         76 $env->{SCRIPT_NAME} = $script_name;
52              
53             # don't touch REQUEST_URI, it will continue to refer to the original
54             }
55              
56 37         143 $self->app->($env);
57             }
58              
59             sub _throw_error {
60 7     7   13 my ($message) = @_;
61 7         54 die Plack::Middleware::ReverseProxyPath::Exception->new($message);
62             }
63              
64             {
65             package Plack::Middleware::ReverseProxyPath::Exception;
66 3     3   53006 use overload '""' => \&message;
  3         9  
  3         25  
67             sub new {
68 7     7   13 my ($class, $message) = @_;
69 7         82 return bless { message => $message }, $class;
70             }
71 10     10   2854 sub code { 500 }
72 17     17   632 sub message { $_[0]->{message} }
73             }
74              
75             1;
76              
77             __END__