Header-injection security fix, without perltidy

[catagits/Catalyst-Runtime.git] / lib / Catalyst / Response.pm

diff --git a/lib/Catalyst/Response.pm b/lib/Catalyst/Response.pm
index 9c571b8..19be6c6 100644 (file)
--- a/lib/Catalyst/Response.pm
+++ b/lib/Catalyst/Response.pm
@@ -20,12 +20,30 @@ subtype 'Catalyst::Engine::Types::Writer',
 
 has _writer => (
     is      => 'ro',
-    isa     => 'Catalyst::Engine::Types::Writer',
-    writer  => '_set_writer',
+    isa     => 'Catalyst::Engine::Types::Writer', #Pointless since we control how this is built
+    #writer  => '_set_writer', Now that its lazy I think this is safe to remove
     clearer => '_clear_writer',
     predicate => '_has_writer',
+    lazy      => 1,
+    builder => '_build_writer',
 );
 
+sub _build_writer {
+    my $self = shift;
+
+    ## These two lines are probably crap now...
+    $self->_context->finalize_headers unless
+      $self->finalized_headers;
+
+    my @headers;
+    $self->headers->scan(sub { push @headers, @_ });
+
+    my $writer = $self->_response_cb->([ $self->status, \@headers ]);
+    $self->_clear_response_cb;
+
+    return $writer;
+}
+
 has write_fh => (
   is=>'ro',
   predicate=>'_has_write_fh',
@@ -33,12 +51,7 @@ has write_fh => (
   builder=>'_build_write_fh',
 );
 
-sub _build_write_fh {
-  my $self = shift;
-  $self->_context->finalize_headers unless
-    $self->finalized_headers;
-  $self->_writer;
-};
+sub _build_write_fh { shift ->_writer }
 
 sub DEMOLISH {
   my $self = shift;
@@ -52,7 +65,7 @@ has cookies   => (is => 'rw', default => sub { {} });
 has body      => (is => 'rw', default => undef);
 sub has_body { defined($_[0]->body) }
 
-has location  => (is => 'rw');
+has location  => (is => 'rw', writer => '_set_location');
 has status    => (is => 'rw', default => 200);
 has finalized_headers => (is => 'rw', default => 0);
 has headers   => (
@@ -69,6 +82,15 @@ has _context => (
   clearer => '_clear_context',
 );
 
+before [qw(status headers content_encoding content_length content_type header)] => sub {
+  my $self = shift;
+
+  $self->_context->log->warn(
+    "Useless setting a header value after finalize_headers called." .
+    " Not what you want." )
+      if ( $self->finalized_headers && @_ );
+};
+
 sub output { shift->body(@_) }
 
 sub code   { shift->status(@_) }
@@ -89,26 +111,6 @@ sub write {
 
 sub finalize_headers {
     my ($self) = @_;
-
-    # This is a less-than-pretty hack to avoid breaking the old
-    # Catalyst::Engine::PSGI. 5.9 Catalyst::Engine sets a response_cb and
-    # expects us to pass headers to it here, whereas Catalyst::Enngine::PSGI
-    # just pulls the headers out of $ctx->response in its run method and never
-    # sets response_cb. So take the lack of a response_cb as a sign that we
-    # don't need to set the headers.
-
-    return unless $self->_has_response_cb;
-
-    # If we already have a writer, we already did this, so don't do it again
-    return if $self->_has_writer;
-
-    my @headers;
-    $self->headers->scan(sub { push @headers, @_ });
-
-    my $writer = $self->_response_cb->([ $self->status, \@headers ]);
-    $self->_set_writer($writer);
-    $self->_clear_response_cb;
-
     return;
 }
 
@@ -118,27 +120,19 @@ sub from_psgi_response {
         my ($status, $headers, $body) = @$psgi_res;
         $self->status($status);
         $self->headers(HTTP::Headers->new(@$headers));
-        if(ref $body eq 'ARRAY') {
-          $self->body(join '', grep defined, @$body);
-        } else {
-          $self->body($body);
-        }
+        $self->body($body);
     } elsif(ref $psgi_res eq 'CODE') {
         $psgi_res->(sub {
             my $response = shift;
             my ($status, $headers, $maybe_body) = @$response;
             $self->status($status);
             $self->headers(HTTP::Headers->new(@$headers));
-            if($maybe_body) {
-                if(ref $maybe_body eq 'ARRAY') {
-                  $self->body(join '', grep defined, @$maybe_body);
-                } else {
-                  $self->body($maybe_body);
-                }
+            if(defined $maybe_body) {
+                $self->body($maybe_body);
             } else {
                 return $self->write_fh;
             }
-        });  
+        });
      } else {
         die "You can't set a Catalyst response from that, expect a valid PSGI response";
     }
@@ -185,7 +179,7 @@ When using a L<IO::Handle> type of object and no content length has been
 already set in the response headers Catalyst will make a reasonable attempt
 to determine the size of the Handle. Depending on the implementation of your
 handle object, setting the content length may fail. If it is at all possible
-for you to determine the content length of your handle object, 
+for you to determine the content length of your handle object,
 it is recommended that you set the content length in the response headers
 yourself, which will be respected and sent by Catalyst in the response.
 
@@ -290,6 +284,23 @@ sub redirect {
     return $self->location;
 }
 
+around '_set_location' => sub {
+  my $orig = shift;
+  my $self = shift;
+
+  if (@_) {
+    my $location = shift;
+
+    if ( $location =~ m/[\n\r]/ ) { # check for header injection
+      die "blocking header injection";
+    } else {
+      $self->$orig($location);
+    }
+  } else {
+    $self->$orig();
+  }
+};
+
 =head2 $res->location
 
 Sets or returns the HTTP 'Location'.
@@ -374,7 +385,7 @@ Example:
     }
 
 Please note this does not attempt to map or nest your PSGI application under
-the Controller and Action namespace or path.  
+the Controller and Action namespace or path.
 
 =head2 DEMOLISH