Permalink
Browse files

initial commit

  • Loading branch information...
miyagawa committed Nov 29, 2009
0 parents commit 1db6bf5155762dc1b2071f028022fec566e937b8
Showing with 271 additions and 0 deletions.
  1. +5 −0 .gitignore
  2. +2 −0 .shipit
  3. +4 −0 Changes
  4. +32 −0 MANIFEST
  5. +14 −0 MANIFEST.SKIP
  6. +13 −0 Makefile.PL
  7. +27 −0 README
  8. +113 −0 lib/Plack/Middleware/Deflater.pm
  9. +4 −0 t/00_compile.t
  10. +35 −0 t/deflater.t
  11. +5 −0 xt/perlcritic.t
  12. +4 −0 xt/pod.t
  13. +9 −0 xt/podspell.t
  14. +4 −0 xt/synopsis.t
@@ -0,0 +1,5 @@
+META.yml
+Makefile
+inc/
+pm_to_blib
+*~
@@ -0,0 +1,2 @@
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
+git.push_to = origin
@@ -0,0 +1,4 @@
+Revision history for Perl extension Plack::Middleware::Deflater
+
+0.01 Sun Nov 29 13:31:48 2009
+ - original version
@@ -0,0 +1,32 @@
+.gitignore
+Changes
+inc/Module/Install.pm
+inc/Module/Install/AuthorTests.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/ReadmeFromPod.pm
+inc/Module/Install/Repository.pm
+inc/Module/Install/TestBase.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+inc/Spiffy.pm
+inc/Test/Base.pm
+inc/Test/Base/Filter.pm
+inc/Test/Builder.pm
+inc/Test/Builder/Module.pm
+inc/Test/More.pm
+lib/Plack/Middleware/Deflater.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/00_compile.t
+t/deflater.t
+xt/perlcritic.t
+xt/pod.t
+xt/podspell.t
+xt/synopsis.t
@@ -0,0 +1,14 @@
+\bRCS\b
+\bCVS\b
+\.svn/
+\.git/
+^MANIFEST\.
+^Makefile$
+~$
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
+\.shipit
@@ -0,0 +1,13 @@
+use inc::Module::Install;
+name 'Plack-Middleware-Deflater';
+all_from 'lib/Plack/Middleware/Deflater.pm';
+readme_from 'lib/Plack/Middleware/Deflater.pm';
+build_requires 'Test::More';
+requires 'Plack';
+requires 'IO::Compress::Gzip';
+requires 'IO::Compress::Deflate';
+use_test_base;
+auto_include_deps;
+author_tests('xt');
+auto_set_repository;
+WriteAll;
27 README
@@ -0,0 +1,27 @@
+NAME
+ Plack::Middleware::Deflater - Compress response body with Gzip or
+ Deflate
+
+SYNOPSIS
+ enable "Deflater";
+
+DESCRIPTION
+ Plack::Middleware::Deflater is a middleware to encode your response body
+ in gzip or deflate, based on "Accept-Encoding" HTTP request header. It
+ would save the bandwidth a little bit but should increase the Plack
+ server load, so ideally you should handle this on the frontend reverse
+ proxy servers.
+
+ This middleware removes "Content-Length" and streams encoded content,
+ which means the server should support HTTP/1.1 chunked response or
+ downgrade to HTTP/1.0 and closes the connection.
+
+LICENSE
+ This software is licensed under the same terms as Perl itself.
+
+AUTHOR
+ Tatsuhiko Miyagawa
+
+SEE ALSO
+ Plack
+
@@ -0,0 +1,113 @@
+package Plack::Middleware::Deflater;
+use strict;
+use 5.008001;
+use parent qw(Plack::Middleware);
+
+use IO::Compress::Deflate;
+use IO::Compress::Gzip;
+use Plack::Util;
+
+sub call {
+ my($self, $env) = @_;
+
+ my $res = $self->app->($env);
+
+ $self->response_cb($res, sub {
+ my $res = shift;
+
+ # do not support streaming response
+ return unless defined $res->[2];
+
+ my $h = Plack::Util::headers($res->[1]);
+ if (Plack::Util::status_with_no_entity_body($res->[0]) or
+ $h->exists('Cache-Control') && $h->get('Cache-Control') =~ /\bno-transform\b/) {
+ return;
+ }
+
+ # TODO check quality
+ my $encoding = 'identity';
+ for my $enc (qw(gzip deflate identity)) {
+ if ($env->{HTTP_ACCEPT_ENCODING} =~ /\b$enc\b/) {
+ $encoding = $enc;
+ last;
+ }
+ }
+
+ my @vary = split /\s*,\s*/, ($h->get('Vary') || '');
+ push @vary, 'Accept-Encoding';
+ $h->set('Vary' => join(",", @vary));
+
+ my $encoder;
+ if ($encoding eq 'gzip') {
+ $encoder = sub { IO::Compress::Gzip->new($_[0]) };
+ } elsif ($encoding eq 'deflate') {
+ $encoder = sub { IO::Compress::Deflate->new($_[0]) };
+ } elsif ($encoding ne 'identity') {
+ my $msg = "An acceptable encoding for the requested resource is not found.";
+ @$res = (406, ['Content-Type' => 'text/plain'], [ $msg ]);
+ return;
+ }
+
+ if ($encoder) {
+ $h->set('Content-Encoding' => $encoding);
+ $h->remove('Content-Length');
+ my($done, $buf);
+ my $compress = $encoder->(\$buf);
+ return sub {
+ my $chunk = shift;
+ return if $done;
+ unless (defined $chunk) {
+ $done = 1;
+ $compress->flush;
+ return $buf;
+ }
+ $compress->print($chunk);
+ if (defined $buf) {
+ my $body = $buf;
+ $buf = undef;
+ return $body;
+ } else {
+ return '';
+ }
+ };
+ }
+ });
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::Deflater - Compress response body with Gzip or Deflate
+
+=head1 SYNOPSIS
+
+ enable "Deflater";
+
+=head1 DESCRIPTION
+
+Plack::Middleware::Deflater is a middleware to encode your response
+body in gzip or deflate, based on C<Accept-Encoding> HTTP request
+header. It would save the bandwidth a little bit but should increase
+the Plack server load, so ideally you should handle this on the
+frontend reverse proxy servers.
+
+This middleware removes C<Content-Length> and streams encoded content,
+which means the server should support HTTP/1.1 chunked response or
+downgrade to HTTP/1.0 and closes the connection.
+
+=head1 LICENSE
+
+This software is licensed under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack>
+
+=cut
@@ -0,0 +1,4 @@
+use strict;
+use Test::More tests => 1;
+
+BEGIN { use_ok 'Plack::Middleware::Deflater' }
@@ -0,0 +1,35 @@
+use strict;
+use Test::More;
+use Test::Requires qw(IO::Handle::Util);
+use IO::Handle::Util qw(:io_from);
+use HTTP::Request::Common;
+use Plack::Test;
+use Plack::Middleware::Deflater;
+$Plack::Test::Impl = "Server";
+
+my @app = (
+ sub { [ 200, [], [ 'Hello World' ] ] },
+ sub { [ 200, [], [ 'Hello ', 'World' ] ] },
+ sub { [ 200, [], [ 'Hello ', '', 'World' ] ] },
+ sub { [ 200, [], io_from_array [ 'Hello World' ] ] },
+ sub { [ 200, [], io_from_array [ 'Hello', ' World' ] ] },
+ sub { [ 200, [], io_from_array [ 'Hello', '', ' World' ] ] },
+);
+
+my $app = sub { (shift @app)->(@_) };
+
+test_psgi app => Plack::Middleware::Deflater->wrap($app), client => sub {
+ my $cb = shift;
+
+ no warnings;
+ local *HTTP::Request::decodable = sub { wantarray ? ('gzip') : 'gzip' };
+ for (0..$#app) {
+ my $req = GET "http://localhost/";
+ $req->accept_decodable;
+ my $res = $cb->($req);
+ is $res->decoded_content, 'Hello World';
+ is $res->content_encoding, 'gzip';
+ }
+};
+
+done_testing;
@@ -0,0 +1,5 @@
+use strict;
+use Test::More;
+eval q{ use Test::Perl::Critic };
+plan skip_all => "Test::Perl::Critic is not installed." if $@;
+all_critic_ok("lib");
@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
@@ -0,0 +1,9 @@
+use Test::More;
+eval q{ use Test::Spelling };
+plan skip_all => "Test::Spelling is not installed." if $@;
+add_stopwords(<DATA>);
+set_spell_cmd("aspell -l en list");
+all_pod_files_spelling_ok('lib');
+__DATA__
+Tatsuhiko
+Miyagawa
@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Synopsis";
+plan skip_all => "Test::Synopsis required" if $@;
+all_synopsis_ok();

0 comments on commit 1db6bf5

Please sign in to comment.