diff options
Diffstat (limited to 'perllib')
| -rw-r--r-- | perllib/Catalyst/Plugin/Compress/Gzip.pm | 82 | ||||
| -rw-r--r-- | perllib/Catalyst/TraitFor/Model/DBIC/Schema/QueryLog/AdoptPlack.pm | 128 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App.pm | 1 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App/Controller/Auth.pm | 20 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App/Controller/Report.pm | 49 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App/Controller/Root.pm | 33 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App/Model/DB.pm | 5 | ||||
| -rw-r--r-- | perllib/FixMyStreet/Cobrand/FixMyStreet.pm | 2 | ||||
| -rw-r--r-- | perllib/FixMyStreet/DB/Result/Problem.pm | 18 | ||||
| -rw-r--r-- | perllib/FixMyStreet/Roles/Extra.pm | 16 |
10 files changed, 244 insertions, 110 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 d782890bc..a09f86f85 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/Controller/Auth.pm b/perllib/FixMyStreet/App/Controller/Auth.pm index 83fb0554c..825066026 100644 --- a/perllib/FixMyStreet/App/Controller/Auth.pm +++ b/perllib/FixMyStreet/App/Controller/Auth.pm @@ -128,6 +128,18 @@ sub email_sign_in : Private { return; } + # If user registration is disabled then bail out at this point + # if there's not already a user with this email address. + # NB this uses the same template as a successful sign in to stop + # enumeration of valid email addresses. + if ( FixMyStreet->config('SIGNUPS_DISABLED') + && !$c->model('DB::User')->search({ email => $good_email })->count + && !$c->stash->{current_user} # don't break the change email flow + ) { + $c->stash->{template} = 'auth/token.html'; + return; + } + my $user_params = {}; $user_params->{password} = $c->get_param('password_register') if $c->get_param('password_register'); @@ -199,6 +211,10 @@ sub token : Path('/M') : Args(1) { my $user = $c->model('DB::User')->find_or_new({ email => $data->{email} }); + # Bail out if this is a new user and SIGNUPS_DISABLED is set + $c->detach( '/page_error_403_access_denied', [] ) + if FixMyStreet->config('SIGNUPS_DISABLED') && !$user->in_storage && !$data->{old_email}; + if ($data->{old_email}) { # Were logged in as old_email, want to switch to email ($user) if ($user->in_storage) { @@ -244,6 +260,8 @@ sub fb : Private { sub facebook_sign_in : Private { my ( $self, $c ) = @_; + $c->detach( '/page_error_403_access_denied', [] ) if FixMyStreet->config('SIGNUPS_DISABLED'); + my $fb = $c->forward('/auth/fb'); my $url = $fb->get_authorization_url(scope => ['email']); @@ -302,6 +320,8 @@ sub tw : Private { sub twitter_sign_in : Private { my ( $self, $c ) = @_; + $c->detach( '/page_error_403_access_denied', [] ) if FixMyStreet->config('SIGNUPS_DISABLED'); + my $twitter = $c->forward('/auth/tw'); my $url = $twitter->get_authentication_url(callback => $c->uri_for('/auth/Twitter')); diff --git a/perllib/FixMyStreet/App/Controller/Report.pm b/perllib/FixMyStreet/App/Controller/Report.pm index c617f5733..60d373a16 100644 --- a/perllib/FixMyStreet/App/Controller/Report.pm +++ b/perllib/FixMyStreet/App/Controller/Report.pm @@ -316,6 +316,10 @@ sub inspect : Private { $c->stash->{templates_by_category} = $templates_by_category; } + if ($c->user->has_body_permission_to('planned_reports')) { + $c->stash->{post_inspect_url} = $c->req->referer; + } + if ( $c->get_param('save') ) { $c->forward('/auth/check_csrf_token'); @@ -438,33 +442,36 @@ sub inspect : Private { anonymous => 0, %update_params, } ); - # This problem might no longer be visible on the current cobrand, - # if its body has changed (e.g. by virtue of the category changing) - # so redirect to a cobrand where it can be seen if necessary - $problem->discard_changes; + my $redirect_uri; - if ( $c->cobrand->is_council && !$c->cobrand->owns_problem($problem) ) { + $problem->discard_changes; + + # If inspector, redirect back to the map view they came from + # with the right filters. If that wasn't set, go to /around at this + # report's location. + # We go here rather than the shortlist because it makes it much + # simpler to inspect many reports in the same location. The + # shortlist is always a single click away, being on the main nav. + if ($c->user->has_body_permission_to('planned_reports')) { + unless ($redirect_uri = $c->get_param("post_inspect_url")) { + my $categories = join(',', @{ $c->user->categories }); + my $params = { + lat => $problem->latitude, + lon => $problem->longitude, + }; + $params->{filter_category} = $categories if $categories; + $params->{js} = 1 if $c->get_param('js'); + $redirect_uri = $c->uri_for( "/around", $params ); + } + } elsif ( $c->cobrand->is_council && !$c->cobrand->owns_problem($problem) ) { + # This problem might no longer be visible on the current cobrand, + # if its body has changed (e.g. by virtue of the category changing) + # so redirect to a cobrand where it can be seen if necessary $redirect_uri = $c->cobrand->base_url_for_report( $problem ) . $problem->url; } else { $redirect_uri = $c->uri_for( $problem->url ); } - # Or if inspector, redirect back to /around at this report's - # location with the right filters. We go here rather than the - # shortlist because it makes it much simpler to inspect many reports - # in the same location. The shortlist is always a single click away, - # being on the main nav. - if ($c->user->has_body_permission_to('planned_reports')) { - my $categories = join(',', @{ $c->user->categories }); - my $params = { - lat => $problem->latitude, - lon => $problem->longitude, - }; - $params->{filter_category} = $categories if $categories; - $params->{js} = 1 if $c->get_param('js'); - $redirect_uri = $c->uri_for( "/around", $params ); - } - $c->log->debug( "Redirecting to: " . $redirect_uri ); $c->res->redirect( $redirect_uri ); } diff --git a/perllib/FixMyStreet/App/Controller/Root.pm b/perllib/FixMyStreet/App/Controller/Root.pm index 64d7fa6ae..7f70623ae 100644 --- a/perllib/FixMyStreet/App/Controller/Root.pm +++ b/perllib/FixMyStreet/App/Controller/Root.pm @@ -16,6 +16,18 @@ FixMyStreet::App::Controller::Root - Root Controller for FixMyStreet::App =head1 METHODS +=head2 begin + +Any pre-flight checking for all requests + +=cut +sub begin : Private { + my ( $self, $c ) = @_; + + $c->forward( 'check_login_required' ); +} + + =head2 auto Set up general things for this instance @@ -130,6 +142,27 @@ sub page_error : Private { $c->response->status($code); } +sub check_login_required : Private { + my ($self, $c) = @_; + + return if $c->user_exists || !FixMyStreet->config('LOGIN_REQUIRED'); + + # Whitelisted URL patterns are allowed without login + my $whitelist = qr{ + ^auth(/|$) + | ^js/translation_strings\.(.*?)\.js + | ^[PACQM]/ # various tokens that log the user in + }x; + return if $c->request->path =~ $whitelist; + + # Blacklisted URLs immediately 404 + # This is primarily to work around a Safari bug where the appcache + # URL is requested in an infinite loop if it returns a 302 redirect. + $c->detach('/page_error_404_not_found', []) if $c->request->path =~ /^offline/; + + $c->detach( '/auth/redirect' ); +} + =head2 end Attempt to render a view, if needed. 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'") } diff --git a/perllib/FixMyStreet/DB/Result/Problem.pm b/perllib/FixMyStreet/DB/Result/Problem.pm index fcffc1e97..77190679b 100644 --- a/perllib/FixMyStreet/DB/Result/Problem.pm +++ b/perllib/FixMyStreet/DB/Result/Problem.pm @@ -890,15 +890,21 @@ sub photos { my $id = $self->id; my @photos = map { my $cachebust = substr($_, 0, 8); + # Some Varnish configurations (e.g. on mySociety infra) strip cookies from + # images, which means image requests will be redirected to the login page + # if LOGIN_REQUIRED is set. To stop this happening, Varnish should be + # configured to not strip cookies if the cookie_passthrough param is + # present, which this line ensures will be if LOGIN_REQUIRED is set. + my $extra = (FixMyStreet->config('LOGIN_REQUIRED')) ? "&cookie_passthrough=1" : ""; my ($hash, $format) = split /\./, $_; { id => $hash, - url_temp => "/photo/temp.$hash.$format", - url_temp_full => "/photo/fulltemp.$hash.$format", - url => "/photo/$id.$i.$format?$cachebust", - url_full => "/photo/$id.$i.full.$format?$cachebust", - url_tn => "/photo/$id.$i.tn.$format?$cachebust", - url_fp => "/photo/$id.$i.fp.$format?$cachebust", + url_temp => "/photo/temp.$hash.$format$extra", + url_temp_full => "/photo/fulltemp.$hash.$format$extra", + url => "/photo/$id.$i.$format?$cachebust$extra", + url_full => "/photo/$id.$i.full.$format?$cachebust$extra", + url_tn => "/photo/$id.$i.tn.$format?$cachebust$extra", + url_fp => "/photo/$id.$i.fp.$format?$cachebust$extra", idx => $i++, } } $photoset->all_ids; diff --git a/perllib/FixMyStreet/Roles/Extra.pm b/perllib/FixMyStreet/Roles/Extra.pm index dc2e5c241..445f6d91c 100644 --- a/perllib/FixMyStreet/Roles/Extra.pm +++ b/perllib/FixMyStreet/Roles/Extra.pm @@ -175,4 +175,20 @@ sub get_extra { return $extra; } +=head2 get_extra_field_value + +Return the value of a field stored in `_fields` in extra, or undefined if +it's not present. + +=cut + +sub get_extra_field_value { + my ($self, $name) = @_; + + my @fields = @{ $self->get_extra_fields() }; + + my ($field) = grep { $_->{name} eq $name } @fields; + return $field->{value}; +} + 1; |