Merge branch 'some-dev-improvements'

5 files changed, 135 insertions, 83 deletions

diff --git a/perllib/Catalyst/Plugin/Compress/Gzip.pm b/perllib/Catalyst/Plugin/Compress/Gzip.pm
deleted file mode 100644
index 06532c84c..000000000
--- a/perllib/Catalyst/Plugin/Compress/Gzip.pm
+++ /dev/null
@@ -1,82 +0,0 @@
-package Catalyst::Plugin::Compress::Gzip;
-use strict;
-use warnings;
-use MRO::Compat;
-
-use Compress::Zlib ();
-
-sub finalize_headers {
-    my $c = shift;
-
-    if ( $c->response->content_encoding ) {
-        return $c->next::method(@_);
-    }
-
-    unless ( $c->response->body ) {
-        return $c->next::method(@_);
-    }
-
-    unless ( $c->response->status == 200 ) {
-        return $c->next::method(@_);
-    }
-
-    unless ( $c->response->content_type =~ /^text|xml$|javascript$/ ) {
-        return $c->next::method(@_);
-    }
-
-    my $accept = $c->request->header('Accept-Encoding') || '';
-
-    unless ( index( $accept, "gzip" ) >= 0 ) {
-        return $c->next::method(@_);
-    }
-
-
-   my $body = $c->response->body;
-   eval { local $/; $body = <$body> } if ref $body;
-   die "Response body is an unsupported kind of reference" if ref $body;
-
-    $c->response->body( Compress::Zlib::memGzip( $body ) );
-    $c->response->content_length( length( $c->response->body ) );
-    $c->response->content_encoding('gzip');
-    $c->response->headers->push_header( 'Vary', 'Accept-Encoding' );
-
-    $c->next::method(@_);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Catalyst::Plugin::Compress::Gzip - Gzip response
-
-=head1 SYNOPSIS
-
-    use Catalyst qw[Compress::Gzip];
-
-
-=head1 DESCRIPTION
-
-Gzip compress response if client supports it. Changed from CPAN version to
-overload finalize_headers, rather than finalize.
-
-=head1 METHODS
-
-=head2 finalize_headers
-
-=head1 SEE ALSO
-
-L<Catalyst>.
-
-=head1 AUTHOR
-
-Christian Hansen, C<ch@ngmedia.com>
-Matthew Somerville.
-
-=head1 LICENSE
-
-This library is free software . You can redistribute it and/or modify it under
-the same terms as perl itself.
-
-=cut
diff --git a/perllib/Catalyst/TraitFor/Model/DBIC/Schema/QueryLog/AdoptPlack.pm b/perllib/Catalyst/TraitFor/Model/DBIC/Schema/QueryLog/AdoptPlack.pm
new file mode 100644
index 000000000..22509568e
--- /dev/null
+++ b/perllib/Catalyst/TraitFor/Model/DBIC/Schema/QueryLog/AdoptPlack.pm
@@ -0,0 +1,128 @@
+# Local version to clone schema in enable_dbic_querylogging
+
+package Catalyst::TraitFor::Model::DBIC::Schema::QueryLog::AdoptPlack;
+our $VERSION = "0.07";
+
+use 5.008004;
+use Moose::Role;
+use Plack::Middleware::DBIC::QueryLog;
+use Scalar::Util 'blessed';
+
+with 'Catalyst::Component::InstancePerContext';
+
+requires 'storage';
+
+has show_missing_ql_warning => (is=>'rw', default=>1);
+
+sub get_querylog_from_env {
+  my ($self, $env) = @_;
+  return Plack::Middleware::DBIC::QueryLog->get_querylog_from_env($env);
+}
+
+sub infer_env_from {
+  my ($self, $ctx) = @_;
+  if($ctx->engine->can('env')) {
+    return $ctx->engine->env;
+  } elsif($ctx->request->can('env')) {
+    return $ctx->request->env;
+  } else { return }
+}
+
+sub enable_dbic_querylogging {
+  my ($self, $querylog) = @_;
+  my $clone = $self->clone;
+  $clone->storage->debugobj($querylog);
+  $clone->storage->debug(1);
+}
+
+sub die_missing_querylog {
+  shift->show_missing_ql_warning(0);
+  die <<DEAD;
+You asked me to querylog DBIC, but there is no querylog object in the Plack
+\$env. You probably forgot to enable Plack::Middleware::Debug::DBIC::QueryLog
+in your debugging panel.
+DEAD
+}
+
+sub die_not_plack {
+  die "Not a Plack Engine or compatible interface!"
+}
+
+sub build_per_context_instance {
+  my ( $self, $ctx ) = @_;
+  return $self unless blessed($ctx);
+
+  if(my $env = $self->infer_env_from($ctx)) {
+    if(my $querylog = $self->get_querylog_from_env($env)) {
+      $self->enable_dbic_querylogging($querylog);
+    } else {
+      $self->die_missing_querylog() if
+        $self->show_missing_ql_warning;
+    }
+  } else {
+    die_not_plack();
+  }
+
+  return $self;
+}
+
+1;
+
+=head1 NAME
+
+Catalyst::TraitFor::Model::DBIC::Schema::QueryLog::AdoptPlack - Use a Plack Middleware QueryLog
+
+=head1 SYNOPSIS
+
+    package MyApp::Web::Model::Schema;
+    use parent 'Catalyst::Model::DBIC::Schema';
+
+	__PACKAGE__->config({
+        schema_class => 'MyApp::Schema',
+        traits => ['QueryLog::AdoptPlack'],
+        ## .. rest of configuration
+	});
+
+=head1 DESCRIPTION
+
+This is a trait for L<Catalyst::Model::DBIC::Schema> which adopts a L<Plack>
+created L<DBIx::Class::QueryLog> and logs SQL for a given request cycle.  It is
+intended to be compatible with L<Catalyst::TraitFor::Model::DBIC::Schema::QueryLog>
+which you may already be using.
+
+It picks up the querylog from C<< $env->{'plack.middleware.dbic.querylog'} >>
+or from  C<< $env->{'plack.middleware.debug.dbic.querylog'} >>  which is generally
+provided by the L<Plack> middleware L<Plack::Middleware::Debug::DBIC::QueryLog>
+In fact you will probably use these two modules together.  Please see the documentation
+in L<Plack::Middleware::Debug::DBIC::QueryLog> for an example.
+
+PLEASE NOTE: Starting with the 0.04 version of L<Plack::Middleware::Debug::DBIC::QueryLog>
+we will canonicalize on C<< $env->{'plack.middleware.dbic.querylog'} >>.  For now
+both listed keys will work, but within a release or two the older key will warn and
+prompt you to upgrade your version of L<Plack::Middleware::Debug::DBIC::QueryLog>.
+Sorry for the trouble.
+
+=head1 SEE ALSO
+
+L<Plack::Middleware::Debug::DBIC::QueryLog>,
+L<Catalyst::TraitFor::Model::DBIC::Schema::QueryLog>,
+L<Catalyst::Model::DBIC::Schema>,
+L<Plack::Middleware::Debug>
+
+=head1 ACKNOWLEGEMENTS
+
+This code inspired from L<Catalyst::TraitFor::Model::DBIC::Schema::QueryLog>
+and the author owes a debt of gratitude for the original authors.
+
+=head1 AUTHOR
+
+John Napiorkowski, C<< <jjnapiork@cpan.org> >>
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2012, John Napiorkowski
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/perllib/FixMyStreet/App.pm b/perllib/FixMyStreet/App.pm
index b7bbc8a0a..25d3d744e 100644
--- a/perllib/FixMyStreet/App.pm
+++ b/perllib/FixMyStreet/App.pm
@@ -25,7 +25,6 @@ use Catalyst (
     'Session::State::Cookie',    # FIXME - we're using our own override atm
     'Authentication',
     'SmartURI',
-    'Compress::Gzip',
 );
 
 extends 'Catalyst';
diff --git a/perllib/FixMyStreet/App/Model/DB.pm b/perllib/FixMyStreet/App/Model/DB.pm
index ffd867485..db8e72c27 100644
--- a/perllib/FixMyStreet/App/Model/DB.pm
+++ b/perllib/FixMyStreet/App/Model/DB.pm
@@ -5,6 +5,7 @@ use strict;
 use warnings;
 
 use FixMyStreet;
+use Catalyst::Utils;
 use Moose;
 
 with 'Catalyst::Component::InstancePerContext';
@@ -13,6 +14,10 @@ __PACKAGE__->config(
     schema_class => 'FixMyStreet::DB::Schema',
     connect_info => sub { FixMyStreet::DB->schema->storage->dbh },
 );
+__PACKAGE__->config(
+    traits => ['QueryLog::AdoptPlack'],
+)
+    if Catalyst::Utils::env_value( 'FixMyStreet::App', 'DEBUG' );
 
 sub build_per_context_instance {
     my ( $self, $c ) = @_;
diff --git a/perllib/FixMyStreet/Cobrand/FixMyStreet.pm b/perllib/FixMyStreet/Cobrand/FixMyStreet.pm
index 1052bac0e..c50721334 100644
--- a/perllib/FixMyStreet/Cobrand/FixMyStreet.pm
+++ b/perllib/FixMyStreet/Cobrand/FixMyStreet.pm
@@ -21,6 +21,8 @@ sub path_to_email_templates {
 
 sub add_response_headers {
     my $self = shift;
+    # uncoverable branch true
+    return if $self->{c}->debug;
     my $csp_nonce = $self->{c}->stash->{csp_nonce} = unpack('h*', mySociety::Random::random_bytes(16, 1));
     $self->{c}->res->header('Content-Security-Policy', "script-src 'self' www.google-analytics.com www.googleadservices.com 'unsafe-inline' 'nonce-$csp_nonce'")
 }