lib/Catalyst/Engine/CGI.pm

   1 package Catalyst::Engine::CGI;
   2
   3 use Moose;
   4 extends 'Catalyst::Engine';
   5
   6 has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf');
   7
   8 =head1 NAME
   9
  10 Catalyst::Engine::CGI - The CGI Engine
  11
  12 =head1 SYNOPSIS
  13
  14 A script using the Catalyst::Engine::CGI module might look like:
  15
  16     #!/usr/bin/perl -w
  17
  18     use strict;
  19     use lib '/path/to/MyApp/lib';
  20     use MyApp;
  21
  22     MyApp->run;
  23
  24 The application module (C<MyApp>) would use C<Catalyst>, which loads the
  25 appropriate engine module.
  26
  27 =head1 DESCRIPTION
  28
  29 This is the Catalyst engine specialized for the CGI environment.
  30
  31 =head1 PATH DECODING
  32
  33 Most web server environments pass the requested path to the application using environment variables,
  34 from which Catalyst has to reconstruct the request base (i.e. the top level path to / in the application,
  35 exposed as C<< $c->request->base >>) and the request path below that base.
  36
  37 There are two methods of doing this, both of which have advantages and disadvantages. Which method is used
  38 is determined by the C<< $c->config(use_request_uri_for_path) >> setting (which can either be true or false).
  39
  40 =head2 use_request_uri_for_path => 0
  41
  42 This is the default (and the) traditional method that Catalyst has used for determining the path information.
  43 The path is synthesised from a combination of the C<PATH_INFO> and C<SCRIPT_NAME> environment variables.
  44 The allows the application to behave correctly when C<mod_rewrite> is being used to redirect requests
  45 into the application, as these variables are adjusted by mod_rewrite to take account for the redirect.
  46
  47 However this method has the major disadvantage that it is impossible to correctly decode some elements
  48 of the path, as RFC 3875 says: "C<< Unlike a URI path, the PATH_INFO is not URL-encoded, and cannot
  49 contain path-segment parameters. >>" This means PATH_INFO is B<always> decoded, and therefore Catalyst
  50 can't distinguish / vs %2F in paths (in addition to other encoded values).
  51
  52 =head2 use_request_uri_for_path => 1
  53
  54 This method uses the C<REQUEST_URI> and C<SCRIPT_NAME> environment variables. As C<REQUEST_URI> is never
  55 decoded, this means that applications using this mode can correctly handle URIs including the %2F character
  56 (i.e. with C<AllowEncodedSlashes> set to C<On> in Apache).
  57
  58 Given that this method of path resolution is provably more correct, it is recommended that you use
  59 this unless you have a specific need to deploy your application in a non-standard environment, and you are
  60 aware of the implications of not being able to handle encoded URI paths correctly.
  61
  62 However it also means that in a number of cases when the app isn't installed directly at a path, but instead
  63 is having paths rewritten into it (e.g. as a .cgi/fcgi in a public_html directory, with mod_rewrite in a
  64 .htaccess file, or when SSI is used to rewrite pages into the app, or when sub-paths of the app are exposed
  65 at other URIs than that which the app is 'normally' based at with C<mod_rewrite>), the resolution of
  66 C<< $c->request->base >> will be incorrect.
  67
  68 =head1 OVERLOADED METHODS
  69
  70 This class overloads some methods from C<Catalyst::Engine>.
  71
  72 =head2 $self->finalize_headers($c)
  73
  74 =cut
  75
  76 sub finalize_headers {
  77     my ( $self, $c ) = @_;
  78
  79     $c->response->header( Status => $c->response->status );
  80
  81     $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012");
  82 }
  83
  84 =head2 $self->prepare_connection($c)
  85
  86 =cut
  87
  88 sub prepare_connection {
  89     my ( $self, $c ) = @_;
  90     local (*ENV) = $self->env || \%ENV;
  91
  92     my $request = $c->request;
  93     $request->address( $ENV{REMOTE_ADDR} );
  94
  95   PROXY_CHECK:
  96     {
  97         unless ( ref($c)->config->{using_frontend_proxy} ) {
  98             last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
  99             last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
 100         }
 101         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
 102
 103         # If we are running as a backend server, the user will always appear
 104         # as 127.0.0.1. Select the most recent upstream IP (last in the list)
 105         my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/;
 106         $request->address($ip);
 107         if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) {
 108             $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT};
 109         }
 110     }
 111
 112     $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST};
 113     $request->protocol( $ENV{SERVER_PROTOCOL} );
 114     $request->user( $ENV{REMOTE_USER} );  # XXX: Deprecated. See Catalyst::Request for removal information
 115     $request->remote_user( $ENV{REMOTE_USER} );
 116     $request->method( $ENV{REQUEST_METHOD} );
 117
 118     if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
 119         $request->secure(1);
 120     }
 121
 122     if ( $ENV{SERVER_PORT} == 443 ) {
 123         $request->secure(1);
 124     }
 125     binmode(STDOUT); # Ensure we are sending bytes.
 126 }
 127
 128 =head2 $self->prepare_headers($c)
 129
 130 =cut
 131
 132 sub prepare_headers {
 133     my ( $self, $c ) = @_;
 134     local (*ENV) = $self->env || \%ENV;
 135     my $headers = $c->request->headers;
 136     # Read headers from %ENV
 137     foreach my $header ( keys %ENV ) {
 138         next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i;
 139         ( my $field = $header ) =~ s/^HTTPS?_//;
 140         $headers->header( $field => $ENV{$header} );
 141     }
 142 }
 143
 144 =head2 $self->prepare_path($c)
 145
 146 =cut
 147
 148 # Please don't touch this method without adding tests in
 149 # t/aggregate/unit_core_engine_cgi-prepare_path.t
 150 sub prepare_path {
 151     my ( $self, $c ) = @_;
 152     local (*ENV) = $self->env || \%ENV;
 153
 154     my $scheme = $c->request->secure ? 'https' : 'http';
 155     my $host      = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
 156     my $port      = $ENV{SERVER_PORT} || 80;
 157
 158     # fix up for IIS
 159     if ($ENV{SERVER_SOFTWARE} && $ENV{SERVER_SOFTWARE} =~ m{IIS/[6-9]\.\d}) {
 160         $ENV{PATH_INFO} =~ s/^\Q$ENV{SCRIPT_NAME}\E//;
 161     }
 162
 163     my $script_name = $ENV{SCRIPT_NAME};
 164     $script_name =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go if $script_name;
 165
 166     my $base_path;
 167     if ( exists $ENV{REDIRECT_URL} ) {
 168         $base_path = $ENV{REDIRECT_URL};
 169         $base_path =~ s/\Q$ENV{PATH_INFO}\E$//;
 170     }
 171     else {
 172         $base_path = $script_name || '/';
 173     }
 174
 175     # If we are running as a backend proxy, get the true hostname
 176   PROXY_CHECK:
 177     {
 178         unless ( ref($c)->config->{using_frontend_proxy} ) {
 179             last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
 180             last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
 181         }
 182         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
 183
 184         $host = $ENV{HTTP_X_FORWARDED_HOST};
 185
 186         # backend could be on any port, so
 187         # assume frontend is on the default port
 188         $port = $c->request->secure ? 443 : 80;
 189         if ( $ENV{HTTP_X_FORWARDED_PORT} ) {
 190             $port = $ENV{HTTP_X_FORWARDED_PORT};
 191         }
 192     }
 193
 194     my $path_info   = $ENV{PATH_INFO};
 195     if ($c->config->{use_request_uri_for_path}) {
 196         # RFC 3875: "Unlike a URI path, the PATH_INFO is not URL-encoded,
 197         # and cannot contain path-segment parameters." This means PATH_INFO
 198         # is always decoded, and the script can't distinguish / vs %2F.
 199         # See https://issues.apache.org/bugzilla/show_bug.cgi?id=35256
 200         # Here we try to resurrect the original encoded URI from REQUEST_URI.
 201         if (my $req_uri = $ENV{REQUEST_URI}) {
 202             if (defined $script_name) {
 203                 $req_uri =~ s/^\Q$script_name\E//;
 204             }
 205             $req_uri =~ s/\?.*$//;
 206             $path_info = $req_uri if $req_uri;
 207         }
 208     }
 209
 210     # set the request URI
 211     my $path = $base_path . ( $path_info || '' );
 212     $path =~ s{^/+}{};
 213
 214     # Using URI directly is way too slow, so we construct the URLs manually
 215     my $uri_class = "URI::$scheme";
 216
 217     # HTTP_HOST will include the port even if it's 80/443
 218     $host =~ s/:(?:80|443)$//;
 219
 220     if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) {
 221         $host .= ":$port";
 222     }
 223
 224     # Escape the path
 225     $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 226     $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 227
 228     my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : '';
 229     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 230
 231     $c->request->uri( bless(\$uri, $uri_class)->canonical );
 232
 233     # set the base URI
 234     # base must end in a slash
 235     $base_path .= '/' unless $base_path =~ m{/$};
 236
 237     my $base_uri = $scheme . '://' . $host . $base_path;
 238
 239     $c->request->base( bless \$base_uri, $uri_class );
 240 }
 241
 242 =head2 $self->prepare_query_parameters($c)
 243
 244 =cut
 245
 246 around prepare_query_parameters => sub {
 247     my $orig = shift;
 248     my ( $self, $c ) = @_;
 249     local (*ENV) = $self->env || \%ENV;
 250
 251     if ( $ENV{QUERY_STRING} ) {
 252         $self->$orig( $c, $ENV{QUERY_STRING} );
 253     }
 254 };
 255
 256 =head2 $self->prepare_request($c, (env => \%env))
 257
 258 =cut
 259
 260 sub prepare_request {
 261     my ( $self, $c, %args ) = @_;
 262
 263     if ( $args{env} ) {
 264         $self->env( $args{env} );
 265     }
 266 }
 267
 268 =head2 $self->prepare_write($c)
 269
 270 Enable autoflush on the output handle for CGI-based engines.
 271
 272 =cut
 273
 274 around prepare_write => sub {
 275     *STDOUT->autoflush(1);
 276     return shift->(@_);
 277 };
 278
 279 =head2 $self->write($c, $buffer)
 280
 281 Writes the buffer to the client.
 282
 283 =cut
 284
 285 around write => sub {
 286     my $orig = shift;
 287     my ( $self, $c, $buffer ) = @_;
 288
 289     # Prepend the headers if they have not yet been sent
 290     if ( $self->_has_header_buf ) {
 291         my $headers = $self->_clear_header_buf;
 292
 293         $buffer = defined $buffer
 294             ? $headers . $buffer : $headers;
 295     }
 296
 297     return $self->$orig( $c, $buffer );
 298 };
 299
 300 =head2 $self->read_chunk($c, $buffer, $length)
 301
 302 =cut
 303
 304 sub read_chunk { shift; shift; *STDIN->sysread(@_); }
 305
 306 =head2 $self->run
 307
 308 =cut
 309
 310 sub run { shift; shift->handle_request( env => \%ENV ) }
 311
 312 =head1 SEE ALSO
 313
 314 L<Catalyst>, L<Catalyst::Engine>
 315
 316 =head1 AUTHORS
 317
 318 Catalyst Contributors, see Catalyst.pm
 319
 320 =head1 COPYRIGHT
 321
 322 This library is free software. You can redistribute it and/or modify it under
 323 the same terms as Perl itself.
 324
 325 =cut
 326 no Moose;
 327
 328 1;