support setting cookies in streaming responses

2 files changed, 262 insertions, 6 deletions

diff --git a/lib/Web/Response.pm b/lib/Web/Response.pm
index 65fc372..0526815 100644
--- a/lib/Web/Response.pm
+++ b/lib/Web/Response.pm
@@ -70,10 +70,14 @@ has streaming_response => (
 );
 
 has cookies => (
+    traits  => ['Hash'],
     is      => 'rw',
     isa     => 'HashRef[Str|HashRef[Str]]',
     lazy    => 1,
     default => sub { +{} },
+    handles => {
+        has_cookies => 'count',
+    },
 );
 
 has _encoding_obj => (
@@ -123,8 +127,6 @@ sub finalize {
     return $self->_finalize_streaming
         if $self->has_streaming_response;
 
-    $self->_finalize_cookies;
-
     my $res = [
         $self->status,
         [
@@ -143,6 +145,8 @@ sub finalize {
         $self->content
     ];
 
+    $self->_finalize_cookies($res);
+
     return $res unless $self->has_encoding;
 
     return Plack::Util::response_cb($res, sub {
@@ -159,11 +163,13 @@ sub _finalize_streaming {
 
     my $streaming = $self->streaming_response;
 
-    # XXX cookies?
-
-    return $streaming unless $self->has_encoding;
+    return $streaming
+        unless $self->has_encoding || $self->has_cookies;
 
     return Plack::Util::response_cb($streaming, sub {
+        my $res = shift;
+        $self->_finalize_cookies($res);
+        return unless $self->has_encoding;
         return sub {
             my $chunk = shift;
             return unless defined $chunk;
@@ -181,10 +187,11 @@ sub _encode {
 
 sub _finalize_cookies {
     my $self = shift;
+    my ($res) = @_;
 
     my $cookies = $self->cookies;
     for my $name (keys %$cookies) {
-        $self->headers->push_header(
+        push @{ $res->[1] }, (
             'Set-Cookie' => $self->_bake_cookie($name, $cookies->{$name}),
         );
     }
diff --git a/t/response-streaming-cookie.t b/t/response-streaming-cookie.t
new file mode 100644
index 0000000..278c20e
--- /dev/null
+++ b/t/response-streaming-cookie.t
@@ -0,0 +1,249 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+
+use HTTP::Request::Common;
+use Web::Request;
+
+{
+    my $app = sub {
+        my $env = shift;
+        my $req = Web::Request->new_from_env($env);
+        my $res = $req->new_response(sub {
+            my $responder = shift;
+            $responder->([ 200, ['X-Thing' => 'stuff'], ["foo"] ]);
+        });
+
+        $res->cookies->{t1} = { value => "bar", domain => '.example.com', path => '/cgi-bin' };
+        $res->cookies->{t2} = { value => "xxx yyy", expires => time + 3600 };
+        $res->cookies->{t3} = { value => "123123", "max-age" => 15 };
+
+        $res->finalize;
+    };
+
+    test_psgi $app, sub {
+        my $cb = shift;
+
+        {
+            my $res = $cb->(GET "/");
+
+            ok($res->is_success)
+                || diag($res->status_line . "\n" . $res->content);
+
+            is(scalar($res->header('X-Thing')), 'stuff');
+
+            my @v = sort $res->header('Set-Cookie');
+            is $v[0], "t1=bar; domain=.example.com; path=/cgi-bin";
+            like $v[1], qr/t2=xxx%20yyy; expires=\w+, \d+-\w+-\d+ \d\d:\d\d:\d\d GMT/;
+            is $v[2], "t3=123123; max-age=15";
+
+            is($res->content, "foo");
+        }
+    };
+}
+
+{
+    my $app = sub {
+        my $env = shift;
+        my $req = Web::Request->new_from_env($env);
+        my $res = $req->new_response(sub {
+            my $responder = shift;
+            my $writer = $responder->([ 200, ['X-Thing' => 'stuff'] ]);
+            $writer->write("foo");
+            $writer->write("bar");
+            $writer->close;
+        });
+
+        $res->cookies->{t1} = { value => "bar", domain => '.example.com', path => '/cgi-bin' };
+        $res->cookies->{t2} = { value => "xxx yyy", expires => time + 3600 };
+        $res->cookies->{t3} = { value => "123123", "max-age" => 15 };
+
+        $res->finalize;
+    };
+
+    test_psgi $app, sub {
+        my $cb = shift;
+
+        {
+            my $res = $cb->(GET "/");
+
+            ok($res->is_success)
+                || diag($res->status_line . "\n" . $res->content);
+
+            is(scalar($res->header('X-Thing')), 'stuff');
+
+            my @v = sort $res->header('Set-Cookie');
+            is $v[0], "t1=bar; domain=.example.com; path=/cgi-bin";
+            like $v[1], qr/t2=xxx%20yyy; expires=\w+, \d+-\w+-\d+ \d\d:\d\d:\d\d GMT/;
+            is $v[2], "t3=123123; max-age=15";
+
+            is($res->content, "foobar");
+        }
+    };
+}
+
+{
+    use utf8;
+    my $app = sub {
+        my $env = shift;
+        my $req = Web::Request->new_from_env($env);
+        my $res = $req->new_response(sub {
+            my $responder = shift;
+            $responder->([ 200, ['X-Thing' => 'stuff'], ["café"] ]);
+        });
+
+        $res->cookies->{t1} = { value => "bar", domain => '.example.com', path => '/cgi-bin' };
+        $res->cookies->{t2} = { value => "xxx yyy", expires => time + 3600 };
+        $res->cookies->{t3} = { value => "123123", "max-age" => 15 };
+
+        $res->finalize;
+    };
+
+    test_psgi $app, sub {
+        my $cb = shift;
+
+        {
+            my $res = $cb->(GET "/");
+
+            ok($res->is_success)
+                || diag($res->status_line . "\n" . $res->content);
+
+            is(scalar($res->header('X-Thing')), 'stuff');
+
+            my @v = sort $res->header('Set-Cookie');
+            is $v[0], "t1=bar; domain=.example.com; path=/cgi-bin";
+            like $v[1], qr/t2=xxx%20yyy; expires=\w+, \d+-\w+-\d+ \d\d:\d\d:\d\d GMT/;
+            is $v[2], "t3=123123; max-age=15";
+
+            is($res->content, "caf\xe9");
+        }
+    };
+}
+
+{
+    use utf8;
+
+    my $app = sub {
+        my $env = shift;
+        my $req = Web::Request->new_from_env($env);
+        my $res = $req->new_response(sub {
+            my $responder = shift;
+            my $writer = $responder->([ 200, ['X-Thing' => 'stuff'] ]);
+            $writer->write("ca");
+            $writer->write("fé");
+            $writer->close;
+        });
+
+        $res->cookies->{t1} = { value => "bar", domain => '.example.com', path => '/cgi-bin' };
+        $res->cookies->{t2} = { value => "xxx yyy", expires => time + 3600 };
+        $res->cookies->{t3} = { value => "123123", "max-age" => 15 };
+
+        $res->finalize;
+    };
+
+    test_psgi $app, sub {
+        my $cb = shift;
+
+        {
+            my $res = $cb->(GET "/");
+
+            ok($res->is_success)
+                || diag($res->status_line . "\n" . $res->content);
+
+            is(scalar($res->header('X-Thing')), 'stuff');
+
+            my @v = sort $res->header('Set-Cookie');
+            is $v[0], "t1=bar; domain=.example.com; path=/cgi-bin";
+            like $v[1], qr/t2=xxx%20yyy; expires=\w+, \d+-\w+-\d+ \d\d:\d\d:\d\d GMT/;
+            is $v[2], "t3=123123; max-age=15";
+
+            is($res->content, "caf\xe9");
+        }
+    };
+}
+
+{
+    use utf8;
+    my $app = sub {
+        my $env = shift;
+        my $req = Web::Request->new_from_env($env);
+        $req->encoding('UTF-8');
+        my $res = $req->new_response(sub {
+            my $responder = shift;
+            $responder->([ 200, ['X-Thing' => 'stuff'], ["café"] ]);
+        });
+
+        $res->cookies->{t1} = { value => "bar", domain => '.example.com', path => '/cgi-bin' };
+        $res->cookies->{t2} = { value => "xxx yyy", expires => time + 3600 };
+        $res->cookies->{t3} = { value => "123123", "max-age" => 15 };
+
+        $res->finalize;
+    };
+
+    test_psgi $app, sub {
+        my $cb = shift;
+
+        {
+            my $res = $cb->(GET "/");
+
+            ok($res->is_success)
+                || diag($res->status_line . "\n" . $res->content);
+
+            is(scalar($res->header('X-Thing')), 'stuff');
+
+            my @v = sort $res->header('Set-Cookie');
+            is $v[0], "t1=bar; domain=.example.com; path=/cgi-bin";
+            like $v[1], qr/t2=xxx%20yyy; expires=\w+, \d+-\w+-\d+ \d\d:\d\d:\d\d GMT/;
+            is $v[2], "t3=123123; max-age=15";
+
+            is($res->content, "caf\xc3\xa9");
+        }
+    };
+}
+
+{
+    use utf8;
+
+    my $app = sub {
+        my $env = shift;
+        my $req = Web::Request->new_from_env($env);
+        $req->encoding('UTF-8');
+        my $res = $req->new_response(sub {
+            my $responder = shift;
+            my $writer = $responder->([ 200, ['X-Thing' => 'stuff'] ]);
+            $writer->write("ca");
+            $writer->write("fé");
+            $writer->close;
+        });
+
+        $res->cookies->{t1} = { value => "bar", domain => '.example.com', path => '/cgi-bin' };
+        $res->cookies->{t2} = { value => "xxx yyy", expires => time + 3600 };
+        $res->cookies->{t3} = { value => "123123", "max-age" => 15 };
+
+        $res->finalize;
+    };
+
+    test_psgi $app, sub {
+        my $cb = shift;
+
+        {
+            my $res = $cb->(GET "/");
+
+            ok($res->is_success)
+                || diag($res->status_line . "\n" . $res->content);
+
+            is(scalar($res->header('X-Thing')), 'stuff');
+
+            my @v = sort $res->header('Set-Cookie');
+            is $v[0], "t1=bar; domain=.example.com; path=/cgi-bin";
+            like $v[1], qr/t2=xxx%20yyy; expires=\w+, \d+-\w+-\d+ \d\d:\d\d:\d\d GMT/;
+            is $v[2], "t3=123123; max-age=15";
+
+            is($res->content, "caf\xc3\xa9");
+        }
+    };
+}
+
+done_testing;