From 6880cf8bc3618b56b871875150d40945e87ea4e2 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Sat, 29 Sep 2012 00:38:18 -0500 Subject: support setting cookies in streaming responses --- lib/Web/Response.pm | 19 +++- t/response-streaming-cookie.t | 249 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 262 insertions(+), 6 deletions(-) create mode 100644 t/response-streaming-cookie.t 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; -- cgit v1.2.3-54-g00ecf