diff options
Diffstat (limited to 'perllib')
89 files changed, 12088 insertions, 3678 deletions
diff --git a/perllib/Carp/Always.pm b/perllib/Carp/Always.pm deleted file mode 100644 index 68bcaee52..000000000 --- a/perllib/Carp/Always.pm +++ /dev/null @@ -1,162 +0,0 @@ - -package Carp::Always; - -use 5.006; -use strict; -use warnings; - -our $VERSION = '0.09'; - -use Carp qw(verbose); # makes carp() cluck and croak() confess - -sub _warn { - if ($_[-1] =~ /\n$/s) { - my $arg = pop @_; - $arg =~ s/ at .*? line .*?\n$//s; - push @_, $arg; - } - warn &Carp::longmess; -} - -sub _die { - if ($_[-1] =~ /\n$/s) { - my $arg = pop @_; - $arg =~ s/ at .*? line .*?\n$//s; - push @_, $arg; - } - die &Carp::longmess; -} - -my %OLD_SIG; - -BEGIN { - @OLD_SIG{qw(__DIE__ __WARN__)} = @SIG{qw(__DIE__ __WARN__)}; - $SIG{__DIE__} = \&_die; - $SIG{__WARN__} = \&_warn; -} - -END { - @SIG{qw(__DIE__ __WARN__)} = @OLD_SIG{qw(__DIE__ __WARN__)}; -} - -1; -__END__ - -=head1 NAME - -Carp::Always - Warns and dies noisily with stack backtraces - -=head1 SYNOPSIS - - use Carp::Always; - -makes every C<warn()> and C<die()> complains loudly in the calling package -and elsewhere. More often used on the command line: - - perl -MCarp::Always script.pl - -=head1 DESCRIPTION - -This module is meant as a debugging aid. It can be -used to make a script complain loudly with stack backtraces -when warn()ing or die()ing. - -Here are how stack backtraces produced by this module -looks: - - # it works for explicit die's and warn's - $ perl -MCarp::Always -e 'sub f { die "arghh" }; sub g { f }; g' - arghh at -e line 1 - main::f() called at -e line 1 - main::g() called at -e line 1 - - # it works for interpreter-thrown failures - $ perl -MCarp::Always -w -e 'sub f { $a = shift; @a = @$a };' \ - -e 'sub g { f(undef) }; g' - Use of uninitialized value in array dereference at -e line 1 - main::f('undef') called at -e line 2 - main::g() called at -e line 2 - -In the implementation, the C<Carp> module does -the heavy work, through C<longmess()>. The -actual implementation sets the signal hooks -C<$SIG{__WARN__}> and C<$SIG{__DIE__}> to -emit the stack backtraces. - -Oh, by the way, C<carp> and C<croak> when requiring/using -the C<Carp> module are also made verbose, behaving -like C<cloak> and C<confess>, respectively. - -=head2 EXPORT - -Nothing at all is exported. - -=head1 ACKNOWLEDGMENTS - -This module was born as a reaction to a release -of L<Acme::JavaTrace> by Sébastien Aperghis-Tramoni. -Sébastien also has a newer module called -L<Devel::SimpleTrace> with the same code and fewer flame -comments on docs. The pruning of the uselessly long -docs of this module were prodded by Michael Schwern. - -Schwern and others told me "the module name stinked" - -it was called C<Carp::Indeed>. After thinking long -and not getting nowhere, I went with nuffin's suggestion -and now it is called C<Carp::Always>. -C<Carp::Indeed> which is now deprecate -lives in its own distribution (which won't go anywhere -but will stay there as a redirection to this module). - -=head1 SEE ALSO - -=over 4 - -=item * - -L<Carp> - -=item * - -L<Acme::JavaTrace> and L<Devel::SimpleTrace> - -=back - -Please report bugs via CPAN RT -http://rt.cpan.org/NoAuth/Bugs.html?Dist=Carp-Always. - -=head1 BUGS - -Every (un)deserving module has its own pet bugs. - -=over 4 - -=item * - -This module does not play well with other modules which fusses -around with C<warn>, C<die>, C<$SIG{'__WARN__'}>, -C<$SIG{'__DIE__'}>. - -=item * - -Test scripts are good. I should write more of these. - -=item * - -I don't know if this module name is still a bug as it was -at the time of C<Carp::Indeed>. - -=back - -=head1 AUTHOR - -Adriano Ferreira, E<lt>ferreira@cpan.orgE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright (C) 2005-2007 by Adriano R. Ferreira - -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/Plugin/Session/State/Cookie.pm b/perllib/Catalyst/Plugin/Session/State/Cookie.pm new file mode 100644 index 000000000..c4b61123b --- /dev/null +++ b/perllib/Catalyst/Plugin/Session/State/Cookie.pm @@ -0,0 +1,359 @@ +package Catalyst::Plugin::Session::State::Cookie; +use Moose; +use namespace::autoclean; + +extends 'Catalyst::Plugin::Session::State'; + +use MRO::Compat; +use Catalyst::Utils (); + +our $VERSION = "0.17"; + +has _deleted_session_id => ( is => 'rw' ); + +sub setup_session { + my $c = shift; + + $c->maybe::next::method(@_); + + $c->_session_plugin_config->{cookie_name} + ||= Catalyst::Utils::appprefix($c) . '_session'; +} + +sub extend_session_id { + my ( $c, $sid, $expires ) = @_; + + if ( my $cookie = $c->get_session_cookie ) { + $c->update_session_cookie( $c->make_session_cookie( $sid ) ); + } + + $c->maybe::next::method( $sid, $expires ); +} + +sub set_session_id { + my ( $c, $sid ) = @_; + + $c->update_session_cookie( $c->make_session_cookie( $sid ) ); + + return $c->maybe::next::method($sid); +} + +sub update_session_cookie { + my ( $c, $updated ) = @_; + + unless ( $c->cookie_is_rejecting( $updated ) ) { + my $cookie_name = $c->_session_plugin_config->{cookie_name}; + $c->response->cookies->{$cookie_name} = $updated; + } +} + +sub cookie_is_rejecting { + my ( $c, $cookie ) = @_; + + if ( $cookie->{path} ) { + return 1 if index '/'.$c->request->path, $cookie->{path}; + } + + return 0; +} + +sub make_session_cookie { + my ( $c, $sid, %attrs ) = @_; + + my $cfg = $c->_session_plugin_config; + my $cookie = { + value => $sid, + ( $cfg->{cookie_domain} ? ( domain => $cfg->{cookie_domain} ) : () ), + ( $cfg->{cookie_path} ? ( path => $cfg->{cookie_path} ) : () ), + %attrs, + }; + + unless ( exists $cookie->{expires} ) { + $cookie->{expires} = $c->calculate_session_cookie_expires(); + } + + #beware: we have to accept also the old syntax "cookie_secure = true" + my $sec = $cfg->{cookie_secure} || 0; # default = 0 (not set) + $cookie->{secure} = 1 unless ( ($sec==0) || ($sec==2) ); + $cookie->{secure} = 1 if ( ($sec==2) && $c->req->secure ); + + $cookie->{httponly} = $cfg->{cookie_httponly}; + $cookie->{httponly} = 1 + unless defined $cookie->{httponly}; # default = 1 (set httponly) + + return $cookie; +} + +sub calc_expiry { # compat + my $c = shift; + $c->maybe::next::method( @_ ) || $c->calculate_session_cookie_expires( @_ ); +} + +sub calculate_session_cookie_expires { + my $c = shift; + my $cfg = $c->_session_plugin_config; + + my $value = $c->maybe::next::method(@_); + return $value if $value; + + if ( exists $c->session->{__cookie_expires} ) { + if ( $c->session->{__cookie_expires} > 0 ) { + return time() + $c->session->{__cookie_expires}; + } + else { + return undef; + } + } + elsif ( exists $cfg->{cookie_expires} ) { + if ( $cfg->{cookie_expires} > 0 ) { + return time() + $cfg->{cookie_expires}; + } + else { + return undef; + } + } + else { + return $c->session_expires; + } +} + +sub set_session_cookie_expire { + my $c = shift; + my $val = shift; + + if ( defined $val ) { + $c->session->{__cookie_expires} = $val; + } + else { + delete $c->session->{__cookie_expires}; + } + # Force the cookie to be regenerated + $c->set_session_id( $c->sessionid ); + return 1; +} + +sub get_session_cookie { + my $c = shift; + + my $cookie_name = $c->_session_plugin_config->{cookie_name}; + + return $c->request->cookies->{$cookie_name}; +} + +sub get_session_id { + my $c = shift; + + if ( !$c->_deleted_session_id and my $cookie = $c->get_session_cookie ) { + my $sid = $cookie->value; + $c->log->debug(qq/Found sessionid "$sid" in cookie/) if $c->debug; + return $sid if $sid; + } + + $c->maybe::next::method(@_); +} + +sub delete_session_id { + my ( $c, $sid ) = @_; + + $c->_deleted_session_id(1); # to prevent get_session_id from returning it + + $c->update_session_cookie( $c->make_session_cookie( $sid, expires => 0 ) ); + + $c->maybe::next::method($sid); +} + +__PACKAGE__ + +__END__ + +=pod + +=head1 NAME + +Catalyst::Plugin::Session::State::Cookie - Maintain session IDs using cookies. + +=head1 SYNOPSIS + + use Catalyst qw/Session Session::State::Cookie Session::Store::Foo/; + +=head1 DESCRIPTION + +In order for L<Catalyst::Plugin::Session> to work the session ID needs to be +stored on the client, and the session data needs to be stored on the server. + +This plugin stores the session ID on the client using the cookie mechanism. + +=head1 PUBLIC METHODS + +=head2 set_session_cookie_expire $ttl_in_seconds + + $c->set_session_cookie_expire(3600); # set to 1 hour + $c->set_session_cookie_expire(0); # expire with browser session + $c->set_session_cookie_expire(undef); # fallback to default + +This lets you change the expiry for the current session's cookie. You can set a +number of seconds, 0 to expire the cookie when the browser quits or undef to +fallback to the configured defaults. The value you choose is persisted. + +Note this value has no effect on the exipry in the session store - it only +affects the cookie itself. + +=head1 METHODS + +=over 4 + +=item make_session_cookie + +Returns a hash reference with the default values for new cookies. + +=item update_session_cookie $hash_ref + +Sets the cookie based on C<cookie_name> in the response object. + +=item calc_expiry + +=item calculate_session_cookie_expires + +=item cookie_is_rejecting + +=item delete_session_id + +=item extend_session_id + +=item get_session_cookie + +=item get_session_id + +=item set_session_id + +=back + +=head1 EXTENDED METHODS + +=over 4 + +=item prepare_cookies + +Will restore if an appropriate cookie is found. + +=item finalize_cookies + +Will set a cookie called C<session> if it doesn't exist or if its value is not +the current session id. + +=item setup_session + +Will set the C<cookie_name> parameter to its default value if it isn't set. + +=back + +=head1 CONFIGURATION + +=over 4 + +=item cookie_name + +The name of the cookie to store (defaults to C<Catalyst::Utils::apprefix($c) . '_session'>). + +=item cookie_domain + +The name of the domain to store in the cookie (defaults to current host) + +=item cookie_expires + +Number of seconds from now you want to elapse before cookie will expire. +Set to 0 to create a session cookie, ie one which will die when the +user's browser is shut down. + +=item cookie_secure + +If this attribute B<set to 0> the cookie will not have the secure flag. + +If this attribute B<set to 1> (or true for backward compatibility) - the cookie +sent by the server to the client will get the secure flag that tells the browser +to send this cookie back to the server only via HTTPS. + +If this attribute B<set to 2> then the cookie will get the secure flag only if +the request that caused cookie generation was sent over https (this option is +not good if you are mixing https and http in your application). + +Default value is 0. + +=item cookie_httponly + +If this attribute B<set to 0>, the cookie will not have HTTPOnly flag. + +If this attribute B<set to 1>, the cookie will got HTTPOnly flag that should +prevent client side Javascript accessing the cookie value - this makes some +sort of session hijacking attacks significantly harder. Unfortunately not all +browsers support this flag (MSIE 6 SP1+, Firefox 3.0.0.6+, Opera 9.5+); if +a browser is not aware of HTTPOnly the flag will be ignored. + +Default value is 1. + +Note1: Many peole are confused by the name "HTTPOnly" - it B<does not mean> +that this cookie works only over HTTP and not over HTTPS. + +Note2: This parameter requires Catalyst::Runtime 5.80005 otherwise is skipped. + +=item cookie_path + +The path of the request url where cookie should be baked. + +=back + +For example, you could stick this in MyApp.pm: + + __PACKAGE__->config( 'Plugin::Session' => { + cookie_domain => '.mydomain.com', + }); + +=head1 CAVEATS + +Sessions have to be created before the first write to be saved. For example: + + sub action : Local { + my ( $self, $c ) = @_; + $c->res->write("foo"); + $c->session( ... ); + ... + } + +Will cause a session ID to not be set, because by the time a session is +actually created the headers have already been sent to the client. + +=head1 SEE ALSO + +L<Catalyst>, L<Catalyst::Plugin::Session>. + +=head1 AUTHORS + +Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt> + +=head1 CONTRIBUTORS + +This module is derived from L<Catalyst::Plugin::Session::FastMmap> code, and +has been heavily modified since. + + Andrew Ford + Andy Grundman + Christian Hansen + Marcus Ramberg + Jonathan Rockway E<lt>jrockway@cpan.orgE<gt> + Sebastian Riedel + Florian Ragwitz + +=head1 COPYRIGHT + +Copyright (c) 2005 - 2009 +the Catalyst::Plugin::Session::State::Cookie L</AUTHORS> and L</CONTRIBUTORS> +as listed above. + +=head1 LICENSE + +This program is free software, you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1; diff --git a/perllib/Cobrand.pm b/perllib/Cobrand.pm deleted file mode 100644 index b1ec6ba75..000000000 --- a/perllib/Cobrand.pm +++ /dev/null @@ -1,249 +0,0 @@ -#!/usr/bin/perl -w -# -# Cobrand.pm: -# Cobranding for FixMyStreet. -# -# -# Copyright (c) 2009 UK Citizens Online Democracy. All rights reserved. -# Email: louise@mysociety.org. WWW: http://www.mysociety.org -# -# $Id: Cobrand.pm,v 1.58 2010-01-06 12:33:25 louise Exp $ - -package Cobrand; -use strict; -use Carp; - -=item get_allowed_cobrands - -Return an array reference of allowed cobrand subdomains - -=cut -sub get_allowed_cobrands { - my $allowed_cobrand_string = mySociety::Config::get('ALLOWED_COBRANDS'); - my @allowed_cobrands = split(/\|/, $allowed_cobrand_string); - return \@allowed_cobrands; -} - -# Cobrand calling functions -my %fns = ( - # Return a site restriction clause and a site key if the cobrand uses a subset of the FixMyStreet - # data. Parameter is any extra data the cobrand needs. Returns an empty string and site key 0 - # if the cobrand uses all the data. - 'site_restriction' => { default => '["", 0]' }, - # Return a contact restriction clause if the cobrand uses a subset of the FixMyStreet contact data. - 'contact_restriction' => { default => "''" }, - # Return the base url to use in links in emails for the cobranded version of the site, parameter is extra data. - 'base_url_for_emails' => { default => 'base_url($cobrand)' }, - # Base URL for the admin interface. - 'admin_base_url' => { default => '0' }, - # URL for writetothem; parameter is COBRAND_DATA. - 'writetothem_url' => { default => '0' }, - # Return the base url for the cobranded version of the site - 'base_url' => { default => "mySociety::Config::get('BASE_URL')" }, - # Return the text that prompts the user to enter their postcode/place name. Parameter is QUERY - 'enter_postcode_text' => { default => '""' }, - # Set the language and domain of the site based on the cobrand and host - 'set_lang_and_domain' => { default => '\&default_set_lang_and_domain' }, - # Return HTML for a list of alert options for the cobrand, given QUERY and OPTIONS. - 'alert_list_options' => { default => '0' }, - # Return N recent photos. If EASTING, NORTHING and DISTANCE are supplied, the photos must be attached to problems - # within DISTANCE of the point defined by EASTING and NORTHING. - 'recent_photos' => { default => '\&Problems::recent_photos' }, - # Return recent problems on the site. - 'recent' => { default => '\&Problems::recent' }, - # Given a QUERY, return a block of html for showing front stats for the site - 'front_stats' => { default => '\&Problems::front_stats' }, - # Given a STRING ($_[1]) representing a location and a QUERY, return a string that - # includes any disambiguating information available - 'disambiguate_location' => { default => '"$_[1]&gl=uk"' }, - # Parameter is EPOCHTIME - 'prettify_epoch' => { default => '0' }, - # Parameters are FORM_NAME, QUERY. Return HTML for any extra needed elements for FORM_NAME - 'form_elements' => { default => "''" }, - # Parameter is UPDATE_DATA, a reference to a hash of non-cobranded update data. Return cobrand extra data for the update - 'cobrand_data_for_generic_update' => { default => "''" }, - # Parameter is PROBLEM_DATA, a reference to a hash of non-cobranded problem data. Return cobrand extra data for the problem - 'cobrand_data_for_generic_problem' => { default => "''" }, - # Parameter is QUERY. Return a string of extra data to be stored with a problem - 'extra_problem_data' => { default => "''" }, - # Parameter is QUERY. Return a string of extra data to be stored with an update - 'extra_update_data' => { default => "''" }, - # Parameter is QUERY. Return a string of extra data to be stored with an alert - 'extra_alert_data' => { default => "''" }, - # Given a QUERY, extract any extra data required by the cobrand - 'extra_data' => { default => "''" }, - # Given a QUERY, return a hash of extra params to be included in - # any URLs in links produced on the page returned by that query. - 'extra_params' => { default => "''" }, - # Returns any extra text to be displayed with a PROBLEM. - 'extra_problem_meta_text' => { default => "''" }, - # Returns any extra text to be displayed with an UPDATE. - 'extra_update_meta_text' => { default => "''" }, - # Given a URL ($_[1]), QUERY, EXTRA_DATA, return a URL with any extra params needed appended to it. - 'url' => { default => '$_[1]' }, - # Return any params to be added to responses - 'header_params' => { default => '{}' }, - # Parameter is QUERY. Return some js to set the root path from which AJAX - # queries should be made. - 'root_path_js' => { default => "'var root_path = \"\";'" }, - # Return the title to be used in page heads. - 'site_title' => { default => "''" }, - # Return the maximum number of items to be given in the list of reports on the map - 'on_map_list_limit' => { default => 'undef' }, - # Return a boolean indicating whether the cobrand allows photo uploads - 'allow_photo_upload' => { default => '1' }, - # Return a boolean indicating whether the cobrand allows the display of crosssell adverts - 'allow_crosssell_adverts' => { default => '1' }, - # Return a boolean indicating whether the cobrand allows photo display - 'allow_photo_display' => { default => '1' }, - # Return a boolean indication whether users should see links next to updates allowing them - # to report them as offensive. - 'allow_update_reporting' => { default => '0' }, - # Parameters are LOCATION, QUERY. Return a boolean indicating whether the - # string LOCATION passes the cobrands checks. - 'geocoded_string_check' => { default => '1' }, - # Paramters are COUNCILS, QUERY, CONTEXT. Return a boolean indicating whether - # COUNCILS pass any extra checks. CONTEXT is where we are on the site. - 'council_check' => { default => "[1, '']" }, - # Return an XSL to be used in rendering feeds - 'feed_xsl' => { default => "'/xsl.xsl'" }, - # Return a boolean indicating whether the cobrand displays a report of all councils - 'all_councils_report' => { default => '1' }, - # Return a boolean indicating whether people should be asked whether this - # is the first time they've reported a problem. - 'ask_ever_reported' => { default => '1' }, - # List of names of pages to display on the admin interface - 'admin_pages' => { default => '0' }, - # Show the problem creation graph in the admin interface - 'admin_show_creation_graph' => { default => '1' }, - # The MaPit types this site handles - 'area_types' => { default => '[qw(DIS LBO MTD UTA CTY COI)]' }, - 'area_min_generation' => { default => '10' }, - # Some cobrands that use a Tilma map have a smaller mid-point to make pin centred - 'tilma_mid_point' => { default => '""' }, -); - -foreach (keys %fns) { - die "Default must be specified for $_" unless $fns{$_}{default} ne ''; - eval <<EOF; -sub $_ { - my (\$cobrand, \@args) = \@_; - return call(\$cobrand, '$_', $fns{$_}{default}, \@args); -} -EOF -} - -# This is the main Cobrand calling function that sees if the Cobrand handles -# the function and responds appropriately. -sub call { - my ($cobrand, $fn, $default, @args) = @_; - return call_default($default, @args) unless $cobrand; - my $handle = cobrand_handle($cobrand); - return call_default($default, @args) unless $handle && $handle->can($fn); - return $handle->$fn(@args); -} - -# If we're not in a Cobrand, or the Cobrand module doesn't offer a function, -# this function works out how to return the default response -sub call_default { - my ($default, @args) = @_; - return $default unless ref $default; - return @$default if ref $default eq 'ARRAY'; # Arrays passed back as values - return $default if ref $default eq 'HASH'; # Hashes passed back as reference - return $default->(@args) if ref $default eq 'CODE'; # Functions are called. - die "Default of $default treatment unknown"; -} - -=item cobrand_handle Q - -Given a query that has the name of a site set, return a handle to the Util module for that -site, if one exists, or zero if not. - -=cut -sub cobrand_handle { - my $cobrand = shift; - - our %handles; - - # Once we have a handle defined, return it. - return $handles{$cobrand} if defined $handles{$cobrand}; - - my $cobrand_class = ucfirst($cobrand); - my $class = "Cobrands::" . $cobrand_class . "::Util"; - eval "use $class"; - - eval{ $handles{$cobrand} = $class->new }; - $handles{$cobrand} = 0 if $@; - return $handles{$cobrand}; -} - -# Cobrand functions to fetch config variables -%fns = ( - # Return the contact name for the cobranded version of the site - # (to be used in emails). - 'contact_name' => 'CONTACT_NAME', - # Return the contact email for the cobranded version of the site - 'contact_email' => 'CONTACT_EMAIL', -); - -foreach (keys %fns) { - eval <<EOF; -sub $_ { - my \$cobrand = shift; - return get_cobrand_conf(\$cobrand, '$fns{$_}'); -} -EOF -} - -=item get_cobrand_conf COBRAND KEY - -Get the value for KEY from the config file for COBRAND - -=cut -sub get_cobrand_conf { - my ($cobrand, $key) = @_; - my $value; - if ($cobrand){ - (my $dir = __FILE__) =~ s{/[^/]*?$}{}; - if (-e "$dir/../conf/cobrands/$cobrand/general"){ - mySociety::Config::set_file("$dir/../conf/cobrands/$cobrand/general"); - $cobrand = uc($cobrand); - $value = mySociety::Config::get($key . "_" . $cobrand, undef); - mySociety::Config::set_file("$dir/../conf/general"); - } - } - if (!defined($value)){ - $value = mySociety::Config::get($key); - } - return $value; -} - -=item email_host COBRAND - -Return the virtual host that sends email for this cobrand - -=cut - -sub email_host { - my ($cobrand) = @_; - my $email_vhost = mySociety::Config::get('EMAIL_VHOST'); - if ($cobrand) { - $email_vhost = mySociety::Config::get('EMAIL_VHOST_'. uc($cobrand), $email_vhost); - } - if ($email_vhost && 'http://' . $email_vhost eq mySociety::Config::get('BASE_URL')) { - return 1; - } else { - return 0; - } -} - -# Default things to do for the set_lang_and_domain call -sub default_set_lang_and_domain { - my ($lang, $unicode) = @_; - mySociety::Locale::negotiate_language('en-gb,English,en_GB|nb,Norwegian,nb_NO', $lang); # XXX Testing - mySociety::Locale::gettext_domain('FixMyStreet', $unicode); - mySociety::Locale::change(); -} - -1; - diff --git a/perllib/Cobrands/.gitignore b/perllib/Cobrands/.gitignore deleted file mode 100644 index 77650dd46..000000000 --- a/perllib/Cobrands/.gitignore +++ /dev/null @@ -1 +0,0 @@ -/Cities
\ No newline at end of file diff --git a/perllib/Cobrands/Barnet/Util.pm b/perllib/Cobrands/Barnet/Util.pm deleted file mode 100644 index e4115c232..000000000 --- a/perllib/Cobrands/Barnet/Util.pm +++ /dev/null @@ -1,117 +0,0 @@ -#!/usr/bin/perl -w -# -# Util.pm: -# Barnet cobranding for FixMyStreet. -# -# Copyright (c) 2009 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org. WWW: http://www.mysociety.org - -package Cobrands::Barnet::Util; -use strict; -use Carp; -use URI::Escape; -use mySociety::VotingArea; - -sub new { - my $class = shift; - return bless {}, $class; -} - -=item site_restriction Q - -Return a site restriction clause and a site key. - -=cut -sub site_restriction{ - return ("and council='2489'", 'barnet'); -} - -=item - -Return the base url for this cobranded site - -=cut - -sub base_url { - my $base_url = mySociety::Config::get('BASE_URL'); - if ($base_url !~ /barnet/) { - $base_url =~ s/http:\/\/(?!www\.)/http:\/\/barnet\./g; - $base_url =~ s/http:\/\/www\./http:\/\/barnet\./g; - } - return $base_url; -} - -=item site_title - -Return the title to be used in page heads - -=cut - -sub site_title { - my ($self) = @_; - return 'Barnet Council FixMyStreet'; -} - -sub enter_postcode_text { - my ($self,$q) = @_; - return 'Enter a Barnet postcode, or street name and area'; -} - -=item council_check COUNCILS QUERY CONTEXT - -Return a boolean indicating whether COUNCILS are okay for the location -in the QUERY, and an error message appropriate to the CONTEXT. - -=cut - -sub council_check { - my ($self, $params, $q, $context) = @_; - my $councils; - if ($params->{all_councils}) { - $councils = $params->{all_councils}; - } elsif (defined $params->{lat}) { - my $parent_types = $mySociety::VotingArea::council_parent_types; - $councils = mySociety::MaPit::call('point', "4326/$params->{lon},$params->{lat}", type => $parent_types); - } - my $council_match = defined $councils->{2489}; - if ($council_match) { - return 1; - } - my $url = 'http://www.fixmystreet.com/'; - $url .= 'alert' if $context eq 'alert'; - $url .= '?pc=' . URI::Escape::uri_escape_utf8($q->param('pc')) if $q->param('pc'); - my $error_msg = "That location is not covered by Barnet. -Please visit <a href=\"$url\">the main FixMyStreet site</a>."; - return (0, $error_msg); -} - -# All reports page only has the one council. -sub all_councils_report { - return 0; -} - -=item disambiguate_location S Q - -Given a string representing a location (street and area expected), -bias the viewport to around Barnet. - -=cut - -sub disambiguate_location { - my ($self, $s, $q) = @_; - $s = "ll=51.612832,-0.218169&spn=0.0563,0.09&$s"; - return $s; -} - -sub recent_photos { - my ($self, $num, $lat, $lon, $dist) = @_; - $num = 2 if $num == 3; - return Problems::recent_photos($num, $lat, $lon, $dist); -} - -sub tilma_mid_point { - return 189; -} - -1; - diff --git a/perllib/Cobrands/Emptyhomes/Util.pm b/perllib/Cobrands/Emptyhomes/Util.pm deleted file mode 100644 index d23857f50..000000000 --- a/perllib/Cobrands/Emptyhomes/Util.pm +++ /dev/null @@ -1,75 +0,0 @@ -#!/usr/bin/perl -w -# -# Util.pm: -# Emptyhomes Cobranding for FixMyStreet. -# -# Copyright (c) 2009 UK Citizens Online Democracy. All rights reserved. -# Email: louise@mysociety.org. WWW: http://www.mysociety.org - -package Cobrands::Emptyhomes::Util; -use strict; -use Carp; - -sub new { - my $class = shift; - return bless {}, $class; -} - -=item - -Return the base url for this cobranded site - -=cut - -sub base_url { - my $base_url = mySociety::Config::get('BASE_URL'); - if ($base_url !~ /emptyhomes/) { - $base_url =~ s/http:\/\//http:\/\/emptyhomes\./g; - } - return $base_url; -} - -sub admin_base_url { - return 'https://secure.mysociety.org/admin/emptyhomes/'; -} - -sub area_types { - return qw(DIS LBO MTD UTA LGD COI); # No CTY -} - -=item set_lang_and_domain LANG UNICODE - -Set the language and text domain for the site based on the query and host. - -=cut - -sub set_lang_and_domain { - my ($self, $lang, $unicode) = @_; - mySociety::Locale::negotiate_language('en-gb,English,en_GB|cy,Cymraeg,cy_GB', $lang); - mySociety::Locale::gettext_domain('FixMyStreet-EmptyHomes', $unicode); - mySociety::Locale::change(); -} - -=item site_title - -Return the title to be used in page heads - -=cut - -sub site_title { - my ($self) = @_; - return _('Report Empty Homes'); -} - -=item feed_xsl - -Return the XSL file path to be used for feeds' - -=cut -sub feed_xsl { - my ($self) = @_; - return '/xsl.eha.xsl'; -} - -1; - diff --git a/perllib/Cobrands/Fiksgatami/Util.pm b/perllib/Cobrands/Fiksgatami/Util.pm deleted file mode 100644 index eb0146ab2..000000000 --- a/perllib/Cobrands/Fiksgatami/Util.pm +++ /dev/null @@ -1,70 +0,0 @@ -#!/usr/bin/perl -w -# -# Util.pm: -# Fiksgatami cobranding for FixMyStreet. -# -# Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org. WWW: http://www.mysociety.org - -package Cobrands::Fiksgatami::Util; -use strict; -use Carp; - -sub new { - my $class = shift; - return bless {}, $class; -} - -sub set_lang_and_domain { - my ($self, $lang, $unicode) = @_; - mySociety::Locale::negotiate_language('en-gb,English,en_GB|nb,Norwegian,nb_NO', 'nb'); - mySociety::Locale::gettext_domain('FixMyStreet', $unicode); - mySociety::Locale::change(); -} - -# If lat/lon are present in the URL, OpenLayers will use that to centre the map. -# Need to specify a zoom to stop it defaulting to null/0. -sub url { - my ($self, $url) = @_; - if ($url =~ /lat=/ && $url !~ /zoom=/) { - $url .= ';zoom=2'; - } - return $url; -} - -sub enter_postcode_text { - my ($self, $q) = @_; - return _('Enter a nearby postcode, or street name and area'); -} - -# Is also adding language parameter -sub disambiguate_location { - my ($self, $s, $q) = @_; - $s = "hl=no&gl=no&$s"; - return $s; -} - -sub geocoded_string_check { - my ($self, $s) = @_; - return 1 if $s =~ /, Norge/; - return 0; -} - -sub area_types { - return ( 'NKO', 'NFY' ); -} - -sub area_min_generation { - return ''; -} - -sub admin_base_url { - return 'http://www.fiksgatami.no/admin/'; -} - -sub writetothem_url { - return 'http://www.norge.no/styresmakter/'; -} - -1; - diff --git a/perllib/Cobrands/Southampton/Util.pm b/perllib/Cobrands/Southampton/Util.pm deleted file mode 100644 index d29b53127..000000000 --- a/perllib/Cobrands/Southampton/Util.pm +++ /dev/null @@ -1,117 +0,0 @@ -#!/usr/bin/perl -w -# -# Util.pm: -# Southampton cobranding for FixMyStreet. -# -# Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org. WWW: http://www.mysociety.org - -package Cobrands::Southampton::Util; -use strict; -use Carp; -use URI::Escape; -use mySociety::VotingArea; - -sub new { - my $class = shift; - return bless {}, $class; -} - -=item site_restriction Q - -Return a site restriction clause and a site key. - -=cut -sub site_restriction { - return ("and council='2567'", 'southampton'); -} - -=item - -Return the base url for this cobranded site - -=cut - -sub base_url { - my $base_url = mySociety::Config::get('BASE_URL'); - if ($base_url !~ /southampton/) { - $base_url =~ s/http:\/\/(?!www\.)/http:\/\/southampton\./g; - $base_url =~ s/http:\/\/www\./http:\/\/southampton\./g; - } - return $base_url; -} - -=item site_title - -Return the title to be used in page heads - -=cut - -sub site_title { - my ($self) = @_; - return 'Southampton City Council FixMyStreet'; -} - -sub enter_postcode_text { - my ($self,$q) = @_; - return 'Enter a Southampton postcode, or street name and area'; -} - -=item council_check COUNCILS QUERY CONTEXT - -Return a boolean indicating whether COUNCILS are okay for the location -in the QUERY, and an error message appropriate to the CONTEXT. - -=cut - -sub council_check { - my ($self, $params, $q, $context) = @_; - my $councils; - if ($params->{all_councils}) { - $councils = $params->{all_councils}; - } elsif (defined $params->{lat}) { - my $parent_types = $mySociety::VotingArea::council_parent_types; - $councils = mySociety::MaPit::call('point', "4326/$params->{lon},$params->{lat}", type => $parent_types); - } - my $council_match = defined $councils->{2567}; - if ($council_match) { - return 1; - } - my $url = 'http://www.fixmystreet.com/'; - $url .= 'alert' if $context eq 'alert'; - $url .= '?pc=' . URI::Escape::uri_escape_utf8($q->param('pc')) if $q->param('pc'); - my $error_msg = "That location is not covered by Southampton. -Please visit <a href=\"$url\">the main FixMyStreet site</a>."; - return (0, $error_msg); -} - -# All reports page only has the one council. -sub all_councils_report { - return 0; -} - -=item disambiguate_location S Q - -Given a string representing a location (street and area expected), -bias the viewport to around Southampton. - -=cut - -sub disambiguate_location { - my ($self, $s, $q) = @_; - $s = "ll=50.913822,-1.400493&spn=0.084628,0.15701&$s"; - return $s; -} - -sub recent_photos { - my ($self, $num, $lat, $lon, $dist) = @_; - $num = 2 if $num == 3; - return Problems::recent_photos($num, $lat, $lon, $dist); -} - -sub tilma_mid_point { - return 189; -} - -1; - diff --git a/perllib/CrossSell.pm b/perllib/CrossSell.pm index e40f2166f..9235d0a03 100644 --- a/perllib/CrossSell.pm +++ b/perllib/CrossSell.pm @@ -62,7 +62,7 @@ sub display_random_twfy_alerts_advert { <input type="hidden" name="site" value="fms"> <input style="font-size:150%" type="submit" value="#; $text =~ s#\[/button\]#"></p>#; - return '<div id="advert_thin" style="text-align:center">' . $text . '</div>'; + return '<div id="advert_thin">' . $text . '</div>'; } sub display_hfyc_cheltenham_advert { @@ -113,7 +113,7 @@ EOF sub display_democracyclub { my (%input) = @_; return <<EOF; -<div id="advert_thin" style="text-align:center"> +<div id="advert_thin"> <h2 style="margin-bottom:0">Help make the next election the most accountable ever</h2> <p style="font-size:120%;margin-top:0.5em;"><a href="http://www.democracyclub.org.uk/">Join Democracy Club</a> and have fun keeping an eye on your election candidates. <a href="http://www.democracyclub.org.uk/">Sign me up</a>! </div> EOF @@ -143,38 +143,6 @@ details. You can unsubscribe at any time.</p> EOF } -sub display_tms_form { - my (%input) = @_; - my %input_h = map { $_ => $input{$_} ? ent($input{$_}) : '' } qw(name email postcode mobile signed_email); - my $auth_signature = $input_h{signed_email}; - return <<EOF; -<h1 style="padding-top:0.5em">Coming Soon: TextMyStreet</h1> - -<p>Exclusive to FixMyStreet users: Sign up for a <strong>brand new</strong>, not-yet-launched -service which will make it easy to send short messages to other people on <strong>your -street</strong> and just round the corner.</p> - -<p>Use it to borrow a strimmer, discuss the weather or report a <strong>lost cat</strong>.</p> - -<form action="/tms-signup" method="post"> -<input type="hidden" name="signed_email" value="$auth_signature"> -<label for="name">Name:</label> -<input type="text" name="name" id="name" value="$input_h{name}" size="30"> -<br><label for="email">Email:</label> -<input type="text" name="email" id="email" value="$input_h{email}" size="30"> -<br><label for="postcode">Postcode:</label> -<input type="text" name="postcode" id="postcode" value="$input_h{postcode}" size="11"> -<br><label for="mobile">Mobile:</label> <input type="text" name="mobile" id="mobile" value="$input_h{mobile}" size="11"> - <input type="submit" class="submit" value="Sign up"> -</form> - -<p>mySociety respects your privacy, and we'll never sell or give away your private -details. Once we launch we'll send you some emails and perhaps some texts -explaining how it works, and it'll never cost you a penny unless we explicitly -say it will. You'll be able to <strong>unsubscribe</strong> at any time.</p> -EOF -} - # Not currently used, needs more explanation and testing; perhaps in future. sub display_gny_groups { my ($lon, $lat) = @_; @@ -197,39 +165,49 @@ EOF # Choose appropriate advert and display it. # $this_site is to stop a site advertising itself. sub display_advert ($$;$%) { - my ($q, $email, $name, %data) = @_; + my ($c, $email, $name, %data) = @_; - return '' unless $q->{site} eq 'fixmystreet'; + return '' unless $c->cobrand->is_default; - if (defined $data{council} && $data{council} eq '2326') { - my ($out, $ad) = display_hfyc_cheltenham_advert($email, $name); - if ($out) { - $q->{scratch} = "advert=$ad"; - return $out; - } - } + #if (defined $data{council} && $data{council} eq '2326') { + # my ($out, $ad) = display_hfyc_cheltenham_advert($email, $name); + # if ($out) { + # $c->stash->{scratch} = "advert=$ad"; + # return $out; + # } + #} #if ($data{lat}) { # my $out = display_gny_groups($data{lon}, $data{lat}); # if ($out) { - # $q->{scratch} = 'advert=gnygroups'; + # $c->stash->{scratch} = 'advert=gnygroups'; # return '<div style="margin: 0 5em; border-top: dotted 1px #666666;">' # . $out . '</div>'; # } #} - #$q->{scratch} = 'advert=demclub0'; + #$c->stash->{scratch} = 'advert=demclub0'; #return display_democracyclub(); + return <<EOF; +<div id="advert_thin"> +<p>Do you have an issue that’s too big for FixMyStreet? +It could be time to petition your council. Try our new site: +<h2 style="margin-top:0; font-size: 150%"> +<a href="http://www.petitionyourcouncil.com/">PetitionYourCouncil</a></p> +</h2> +</div> +EOF + #unless (defined $data{done_tms} && $data{done_tms}==1) { - $q->{scratch} = 'advert=news'; - my $auth_signature = ''; - unless (defined $data{emailunvalidated} && $data{emailunvalidated}==1) { - $auth_signature = mySociety::AuthToken::sign_with_shared_secret($email, mySociety::Config::get('AUTH_SHARED_SECRET')); - } - return '<div style="margin: 0 5em; border-top: dotted 1px #666666;">' - . display_news_form(email => $email, name => $name, signed_email => $auth_signature) - . '</div>'; + #$c->stash->{scratch} = 'advert=news'; + #my $auth_signature = ''; + #unless (defined $data{emailunvalidated} && $data{emailunvalidated}==1) { + # $auth_signature = mySociety::AuthToken::sign_with_shared_secret($email, mySociety::Config::get('AUTH_SHARED_SECRET')); + #} + #return '<div style="margin: 0 5em; border-top: dotted 1px #666666;">' + # . display_news_form(email => $email, name => $name, signed_email => $auth_signature) + # . '</div>'; #} my @adverts = ( @@ -250,7 +228,7 @@ sub display_advert ($$;$%) { my $out = &$func($email, $name, $advert_text); use strict 'refs'; if ($out) { - $q->{scratch} = "advert=$advert_id"; + $c->stash->{scratch} = "advert=$advert_id"; return $out; } @@ -260,9 +238,9 @@ sub display_advert ($$;$%) { } } - $q->{scratch} = 'advert=pb'; + $c->stash->{scratch} = 'advert=pb'; return <<EOF; -<div id="advert_thin" style="text-align:center"> +<div id="advert_thin"> <h2 style="font-size: 150%"> If you're interested in improving your local area, <a href="http://www.pledgebank.com/">use PledgeBank</a> to diff --git a/perllib/DBIx/Class/EncodedColumn.pm b/perllib/DBIx/Class/EncodedColumn.pm new file mode 100644 index 000000000..b4a08b35c --- /dev/null +++ b/perllib/DBIx/Class/EncodedColumn.pm @@ -0,0 +1,262 @@ +package DBIx::Class::EncodedColumn; + +use strict; +use warnings; + +use base qw/DBIx::Class/; +use Sub::Name; + +__PACKAGE__->mk_classdata( '_column_encoders' ); + +our $VERSION = '0.00011'; +$VERSION = eval $VERSION; + +sub register_column { + my $self = shift; + my ($column, $info) = @_; + $self->next::method(@_); + + return unless exists $info->{encode_column} && $info->{encode_column} == 1; + $self->throw_exception("'encode_class' is a required argument.") + unless exists $info->{encode_class} && defined $info->{encode_class}; + my $class = $info->{encode_class}; + + my $args = exists $info->{encode_args} ? $info->{encode_args} : {}; + $self->throw_exception("'encode_args' must be a hashref") + unless ref $args eq 'HASH'; + + $class = join("::", 'DBIx::Class::EncodedColumn', $class); + eval "require ${class};"; + $self->throw_exception("Failed to use encode_class '${class}': $@") if $@; + + defined( my $encode_sub = eval{ $class->make_encode_sub($column, $args) }) || + $self->throw_exception("Failed to create encoder with class '$class': $@"); + $self->_column_encoders({$column => $encode_sub, %{$self->_column_encoders || {}}}); + + if ( exists $info->{encode_check_method} && $info->{encode_check_method} ){ + no strict 'refs'; + defined( my $check_sub = eval{ $class->make_check_sub($column, $args) }) || + $self->throw_exception("Failed to create checker with class '$class': $@"); + my $name = join '::', $self->result_class, $info->{encode_check_method}; + *$name = subname $name, $check_sub; + } +} + +# mySociety override to allow direct setting without double encryption +sub set_column { + my $self = shift; + return $self->next::method(@_) unless defined $_[1] and not defined $_[2]; + my $encs = $self->_column_encoders; + if(exists $encs->{$_[0]} && defined(my $encoder = $encs->{$_[0]})){ + return $self->next::method($_[0], $encoder->($_[1])); + } + $self->next::method(@_); +} + +sub new { + my($self, $attr, @rest) = @_; + my $encoders = $self->_column_encoders; + for my $col (grep { defined $encoders->{$_} } keys %$encoders ) { + next unless exists $attr->{$col} && defined $attr->{$col}; + $attr->{$col} = $encoders->{$col}->( $attr->{$col} ); + } + return $self->next::method($attr, @rest); +} + +1; + +__END__; + +=head1 NAME + +DBIx::Class::EncodedColumn - Automatically encode columns + +=head1 SYNOPSIS + +In your L<DBIx::Class> Result class +(sometimes erroneously referred to as the 'table' class): + + __PACKAGE__->load_components(qw/EncodedColumn ... Core/); + + #Digest encoder with hex format and SHA-1 algorithm + __PACKAGE__->add_columns( + 'password' => { + data_type => 'CHAR', + size => 40, + encode_column => 1, + encode_class => 'Digest', + encode_args => {algorithm => 'SHA-1', format => 'hex'}, + } + + #SHA-1 / hex encoding / generate check method + __PACKAGE__->add_columns( + 'password' => { + data_type => 'CHAR', + size => 40 + 10, + encode_column => 1, + encode_class => 'Digest', + encode_args => {algorithm => 'SHA-1', format => 'hex', salt_length => 10}, + encode_check_method => 'check_password', + } + + #MD5 / base64 encoding / generate check method + __PACKAGE__->add_columns( + 'password' => { + data_type => 'CHAR', + size => 22, + encode_column => 1, + encode_class => 'Digest', + encode_args => {algorithm => 'MD5', format => 'base64'}, + encode_check_method => 'check_password', + } + + #Eksblowfish bcrypt / cost of 8/ no key_nul / generate check method + __PACKAGE__->add_columns( + 'password' => { + data_type => 'CHAR', + size => 59, + encode_column => 1, + encode_class => 'Crypt::Eksblowfish::Bcrypt', + encode_args => { key_nul => 0, cost => 8 }, + encode_check_method => 'check_password', + } + +In your application code: + + #updating the value. + $row->password('plaintext'); + my $digest = $row->password; + + #checking against an existing value with a check_method + $row->check_password('old_password'); #true + $row->password('new_password'); + $row->check_password('new_password'); #returns true + $row->check_password('old_password'); #returns false + + +B<Note:> The component needs to be loaded I<before> Core. + +=head1 DESCRIPTION + +This L<DBIx::Class> component can be used to automatically encode a column's +contents whenever the value of that column is set. + +This module is similar to the existing L<DBIx::Class::DigestColumns>, but there +is some key differences: + +=over 4 + +=item C<DigestColumns> performs the encode operation on C<insert> and C<update>, +and C<EncodedColumn> performs the operation when the value is set, or on C<new>. + +=item C<DigestColumns> supports only algorithms of the L<Digest> family. +C<EncodedColumn> employs a set of thin wrappers around different cipher modules +to provide support for any cipher you wish to use and wrappers are very simple +to write (typically less than 30 lines). + +=item C<EncodedColumn> supports having more than one encoded column per table +and each column can use a different cipher. + +=item C<Encode> adds only one item to the namespace of the object utilizing +it (C<_column_encoders>). + +=back + +There is, unfortunately, some features that C<EncodedColumn> doesn't support. +C<DigestColumns> supports changing certain options at runtime, as well as +the option to not automatically encode values on set. The author of this module +found these options to be non-essential and omitted them by design. + +=head1 Options added to add_column + +If any one of these options is present the column will be treated as a digest +column and all of the defaults will be applied to the rest of the options. + +=head2 encode_enable => 1 + +Enable automatic encoding of column values. If this option is not set to true +any other options will become no-ops. + +=head2 encode_check_method => $method_name + +By using the encode_check_method attribute when you declare a column you +can create a check method for that column. The check method accepts a plain +text string, and returns a boolean that indicates whether the digest of the +provided value matches the current value. + +=head2 encode_class + +The class to use for encoding. Available classes are: + +=over 4 + +=item C<Crypt::Eksblowfish::Bcrypt> - uses +L<DBIx::Class::EncodedColumn::Crypt::Eksblowfish::Bcrypt> and +requires L<Crypt::Eksblowfish::Bcrypt> to be installed + +=item C<Digest> - uses L<DBIx::Class::EncodedColumn::Digest> +requires L<Digest> to be installed as well as the algorithm required +(L<Digest::SHA>, L<Digest::Whirlpool>, etc) + +=item C<Crypt::OpenPGP> - L<DBIx::Class::EncodedColumn::Crypt::OpenPGP> +and requires L<Crypt::OpenPGP> to be installed + +=back + +Please see the relevant class's documentation for information about the +specific arguments accepted by each and make sure you include the encoding +algorithm (e.g. L<Crypt::OpenPGP>) in your application's requirements. + +=head1 EXTENDED METHODS + +The following L<DBIx::Class::ResultSource> method is extended: + +=over 4 + +=item B<register_column> - Handle the options described above. + +=back + +The following L<DBIx::Class::Row> methods are extended by this module: + +=over 4 + +=item B<new> - Encode the columns on new() so that copy and create DWIM. + +=item B<set_column> - Encode values whenever column is set. + +=back + +=head1 SEE ALSO + +L<DBIx::Class::DigestColumns>, L<DBIx::Class>, L<Digest> + +=head1 AUTHOR + +Guillermo Roditi (groditi) <groditi@cpan.org> + +Inspired by the original module written by Tom Kirkpatrick (tkp) <tkp@cpan.org> +featuring contributions from Guillermo Roditi (groditi) <groditi@cpan.org> +and Marc Mims <marc@questright.com> + +=head1 CONTRIBUTORS + +jshirley - J. Shirley <cpan@coldhardcode.com> + +kentnl - Kent Fredric <kentnl@cpan.org> + +mst - Matt S Trout <mst@shadowcat.co.uk> + +wreis - Wallace reis <wreis@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2008 - 2009 the DBIx::Class::EncodedColumn L</AUTHOR> and +L</CONTRIBUTORS> as listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. + +=cut diff --git a/perllib/FixMyStreet.pm b/perllib/FixMyStreet.pm new file mode 100644 index 000000000..d63f708d2 --- /dev/null +++ b/perllib/FixMyStreet.pm @@ -0,0 +1,158 @@ +package FixMyStreet; + +use strict; +use warnings; + +use Path::Class; +my $ROOT_DIR = file(__FILE__)->parent->parent->absolute->resolve; + +use Readonly; + +use mySociety::Config; +use mySociety::DBHandle; + +# load the config file and store the contents in a readonly hash +mySociety::Config::set_file( __PACKAGE__->path_to("conf/general") ); +Readonly::Hash my %CONFIG, %{ mySociety::Config::get_list() }; + +=head1 NAME + +FixMyStreet + +=head1 DESCRIPTION + +FixMyStreet is a webite where you can report issues and have them routed to the +correct authority so that they can be fixed. + +Thus module has utility functions for the FMS project. + +=head1 METHODS + +=head2 test_mode + + FixMyStreet->test_mode( $bool ); + my $in_test_mode_bool = FixMyStreet->test_mode; + +Put the FixMyStreet into test mode - inteded for the unit tests: + + BEGIN { + use FixMyStreet; + FixMyStreet->test_mode(1); + } + +=cut + +my $TEST_MODE = undef; + +sub test_mode { + my $class = shift; + $TEST_MODE = shift if scalar @_; + return $TEST_MODE; +} + +=head2 path_to + + $path = FixMyStreet->path_to( 'conf/general' ); + +Returns an absolute Path::Class object representing the path to the arguments in +the FixMyStreet directory. + +=cut + +sub path_to { + my $class = shift; + return $ROOT_DIR->file(@_); +} + +=head2 config + + my $config_hash_ref = FixMyStreet->config(); + my $config_value = FixMyStreet->config($key); + +Returns a hashref to the config values. This is readonly so any attempt to +change it will fail. + +Or you can pass it a key and it will return the value for that key, or undef if +it can't find it. + +=cut + +sub config { + my $class = shift; + return \%CONFIG unless scalar @_; + + my $key = shift; + return exists $CONFIG{$key} ? $CONFIG{$key} : undef; +} + +=head2 dbic_connect_info + + $connect_info = FixMyStreet->dbic_connect_info(); + +Returns the array that DBIx::Class::Schema needs to connect to the database. +Most of the values are read from the config file and others are hordcoded here. + +=cut + +# for exact details on what this could return refer to: +# +# http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Storage/DBI.pm#connect_info +# +# we use the one that is most similar to DBI's connect. + +# FIXME - should we just use mySociety::DBHandle? will that lead to AutoCommit +# woes (we want it on, it sets it to off)? + +sub dbic_connect_info { + my $class = shift; + my $config = $class->config; + + my $dsn = "dbi:Pg:dbname=" . $config->{BCI_DB_NAME}; + $dsn .= ";host=$config->{BCI_DB_HOST}" + if $config->{BCI_DB_HOST}; + $dsn .= ";port=$config->{BCI_DB_PORT}" + if $config->{BCI_DB_PORT}; + $dsn .= ";sslmode=allow"; + + my $user = $config->{BCI_DB_USER} || undef; + my $password = $config->{BCI_DB_PASS} || undef; + + my $dbi_args = { + AutoCommit => 1, + pg_enable_utf8 => 1, + }; + my $dbic_args = {}; + + return [ $dsn, $user, $password, $dbi_args, $dbic_args ]; +} + +=head2 configure_mysociety_dbhandle + + FixMyStreet->configure_mysociety_dbhandle(); + +Calls configure in mySociety::DBHandle with args from the config. We need to do +this so that old code that uses mySociety::DBHandle finds it properly set up. We +can't (might not) be able to share the handle as DBIx::Class wants it with +AutoCommit on (so that its transaction code can be used in preference to calling +begin and commit manually) and mySociety::* code does not. + +This should be fixed/standardized to avoid having two database handles floating +around. + +=cut + +sub configure_mysociety_dbhandle { + my $class = shift; + my $config = $class->config; + + mySociety::DBHandle::configure( + Name => $config->{BCI_DB_NAME}, + User => $config->{BCI_DB_USER}, + Password => $config->{BCI_DB_PASS}, + Host => $config->{BCI_DB_HOST} || undef, + Port => $config->{BCI_DB_PORT} || undef, + ); + +} + +1; diff --git a/perllib/FixMyStreet/Alert.pm b/perllib/FixMyStreet/Alert.pm deleted file mode 100644 index 58a338432..000000000 --- a/perllib/FixMyStreet/Alert.pm +++ /dev/null @@ -1,347 +0,0 @@ -#!/usr/bin/perl -w -# -# FixMyStreet::Alert.pm -# Alerts by email or RSS. -# -# Copyright (c) 2007 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ -# -# $Id: Alert.pm,v 1.71 2010-01-06 16:50:27 louise Exp $ - -package FixMyStreet::Alert::Error; - -use Error qw(:try); - -@FixMyStreet::Alert::Error::ISA = qw(Error::Simple); - -package FixMyStreet::Alert; - -use strict; -use Error qw(:try); -use File::Slurp; -use FindBin; -use POSIX qw(strftime); -use XML::RSS; - -use Cobrand; -use mySociety::AuthToken; -use mySociety::Config; -use mySociety::DBHandle qw(dbh); -use mySociety::Email; -use mySociety::EmailUtil; -use mySociety::Gaze; -use mySociety::Locale; -use mySociety::MaPit; -use mySociety::Random qw(random_bytes); -use mySociety::Sundries qw(ordinal); -use mySociety::Web qw(ent); - -# Add a new alert -sub create ($$$$;@) { - my ($email, $alert_type, $cobrand, $cobrand_data, @params) = @_; - my $already = 0; - if (0==@params) { - ($already) = dbh()->selectrow_array('select id from alert where alert_type=? and email=? limit 1', - {}, $alert_type, $email); - } elsif (1==@params) { - ($already) = dbh()->selectrow_array('select id from alert where alert_type=? and email=? and parameter=? limit 1', - {}, $alert_type, $email, @params); - } elsif (2==@params) { - ($already) = dbh()->selectrow_array('select id from alert where alert_type=? and email=? and parameter=? and parameter2=? limit 1', - {}, $alert_type, $email, @params); - } - return $already if $already; - - my $id = dbh()->selectrow_array("select nextval('alert_id_seq');"); - my $lang = $mySociety::Locale::lang; - if (0==@params) { - dbh()->do('insert into alert (id, alert_type, email, lang, cobrand, cobrand_data) - values (?, ?, ?, ?, ?, ?)', {}, $id, $alert_type, $email, $lang, $cobrand, $cobrand_data); - } elsif (1==@params) { - dbh()->do('insert into alert (id, alert_type, parameter, email, lang, cobrand, cobrand_data) - values (?, ?, ?, ?, ?, ?, ?)', {}, $id, $alert_type, @params, $email, $lang, $cobrand, $cobrand_data); - } elsif (2==@params) { - dbh()->do('insert into alert (id, alert_type, parameter, parameter2, email, lang, cobrand, cobrand_data) - values (?, ?, ?, ?, ?, ?, ?, ?)', {}, $id, $alert_type, @params, $email, $lang, $cobrand, $cobrand_data); - } - dbh()->commit(); - return $id; -} - -sub confirm ($) { - my $id = shift; - dbh()->do("update alert set confirmed=1, whendisabled=null where id=?", {}, $id); - dbh()->commit(); -} - -# Delete an alert -sub delete ($) { - my $id = shift; - dbh()->do('update alert set whendisabled = ms_current_timestamp() where id = ?', {}, $id); - dbh()->commit(); -} - -# This makes load of assumptions, but still should be useful -# -# Child must have confirmed, id, email, state(!) columns -# If parent/child, child table must also have name and text -# and foreign key to parent must be PARENT_id - -sub email_alerts ($) { - my ($testing_email) = @_; - my $url; - my $q = dbh()->prepare("select * from alert_type where ref not like '%local_problems%'"); - $q->execute(); - my $testing_email_clause = ''; - while (my $alert_type = $q->fetchrow_hashref) { - my $ref = $alert_type->{ref}; - my $head_table = $alert_type->{head_table}; - my $item_table = $alert_type->{item_table}; - my $testing_email_clause = "and $item_table.email <> '$testing_email'" if $testing_email; - my $query = 'select alert.id as alert_id, alert.email as alert_email, alert.lang as alert_lang, alert.cobrand as alert_cobrand, - alert.cobrand_data as alert_cobrand_data, alert.parameter as alert_parameter, alert.parameter2 as alert_parameter2, '; - if ($head_table) { - $query .= " - $item_table.id as item_id, $item_table.name as item_name, $item_table.text as item_text, - $head_table.* - from alert - inner join $item_table on alert.parameter::integer = $item_table.${head_table}_id - inner join $head_table on alert.parameter::integer = $head_table.id"; - } else { - $query .= " $item_table.*, - $item_table.id as item_id - from alert, $item_table"; - } - $query .= " - where alert_type='$ref' and whendisabled is null and $item_table.confirmed >= whensubscribed - and $item_table.confirmed >= ms_current_timestamp() - '7 days'::interval - and (select whenqueued from alert_sent where alert_sent.alert_id = alert.id and alert_sent.parameter::integer = $item_table.id) is null - and $item_table.email <> alert.email - $testing_email_clause - and $alert_type->{item_where} - and alert.confirmed = 1 - order by alert.id, $item_table.confirmed"; - # XXX Ugh - needs work - $query =~ s/\?/alert.parameter/ if ($query =~ /\?/); - $query =~ s/\?/alert.parameter2/ if ($query =~ /\?/); - $query = dbh()->prepare($query); - $query->execute(); - my $last_alert_id; - my %data = ( template => $alert_type->{template}, data => '' ); - while (my $row = $query->fetchrow_hashref) { - # Cobranded and non-cobranded messages can share a database. In this case, the conf file - # should specify a vhost to send the reports for each cobrand, so that they don't get sent - # more than once if there are multiple vhosts running off the same database. The email_host - # call checks if this is the host that sends mail for this cobrand. - next unless (Cobrand::email_host($row->{alert_cobrand})); - - dbh()->do('insert into alert_sent (alert_id, parameter) values (?,?)', {}, $row->{alert_id}, $row->{item_id}); - if ($last_alert_id && $last_alert_id != $row->{alert_id}) { - _send_aggregated_alert_email(%data); - %data = ( template => $alert_type->{template}, data => '' ); - } - - # create problem status message for the templates - $data{state_message} = - $row->{state} eq 'fixed' - ? _("This report is currently marked as fixed.") - : _("This report is currently marked as open."); - - $url = Cobrand::base_url_for_emails($row->{alert_cobrand}, $row->{alert_cobrand_data}); - if ($row->{item_text}) { - $data{problem_url} = $url . "/report/" . $row->{id}; - $data{data} .= $row->{item_name} . ' : ' if $row->{item_name}; - $data{data} .= $row->{item_text} . "\n\n------\n\n"; - } else { - $data{data} .= $url . "/report/" . $row->{id} . " - $row->{title}\n\n"; - } - if (!$data{alert_email}) { - %data = (%data, %$row); - if ($ref eq 'area_problems' || $ref eq 'council_problems' || $ref eq 'ward_problems') { - my $va_info = mySociety::MaPit::call('area', $row->{alert_parameter}); - $data{area_name} = $va_info->{name}; - } - if ($ref eq 'ward_problems') { - my $va_info = mySociety::MaPit::call('area', $row->{alert_parameter2}); - $data{ward_name} = $va_info->{name}; - } - } - $data{cobrand} = $row->{alert_cobrand}; - $data{cobrand_data} = $row->{alert_cobrand_data}; - $data{lang} = $row->{alert_lang}; - $last_alert_id = $row->{alert_id}; - } - if ($last_alert_id) { - _send_aggregated_alert_email(%data); - } - } - - # Nearby done separately as the table contains the parameters - my $template = dbh()->selectrow_array("select template from alert_type where ref = 'local_problems'"); - my $query = "select * from alert where alert_type='local_problems' and whendisabled is null and confirmed=1 order by id"; - $query = dbh()->prepare($query); - $query->execute(); - while (my $alert = $query->fetchrow_hashref) { - next unless (Cobrand::email_host($alert->{cobrand})); - my $longitude = $alert->{parameter}; - my $latitude = $alert->{parameter2}; - $url = Cobrand::base_url_for_emails($alert->{cobrand}, $alert->{cobrand_data}); - my ($site_restriction, $site_id) = Cobrand::site_restriction($alert->{cobrand}, $alert->{cobrand_data}); - my $d = mySociety::Gaze::get_radius_containing_population($latitude, $longitude, 200000); - # Convert integer to GB locale string (with a ".") - $d = mySociety::Locale::in_gb_locale { - sprintf("%f", int($d*10+0.5)/10); - }; - my $testing_email_clause = "and problem.email <> '$testing_email'" if $testing_email; - my %data = ( template => $template, data => '', alert_id => $alert->{id}, alert_email => $alert->{email}, lang => $alert->{lang}, cobrand => $alert->{cobrand}, cobrand_data => $alert->{cobrand_data} ); - my $q = "select * from problem_find_nearby(?, ?, ?) as nearby, problem - where nearby.problem_id = problem.id and problem.state in ('confirmed', 'fixed') - and problem.confirmed >= ? and problem.confirmed >= ms_current_timestamp() - '7 days'::interval - and (select whenqueued from alert_sent where alert_sent.alert_id = ? and alert_sent.parameter::integer = problem.id) is null - and problem.email <> ? - $testing_email_clause - $site_restriction - order by confirmed desc"; - $q = dbh()->prepare($q); - $q->execute($latitude, $longitude, $d, $alert->{whensubscribed}, $alert->{id}, $alert->{email}); - while (my $row = $q->fetchrow_hashref) { - dbh()->do('insert into alert_sent (alert_id, parameter) values (?,?)', {}, $alert->{id}, $row->{id}); - $data{data} .= $url . "/report/" . $row->{id} . " - $row->{title}\n\n"; - } - _send_aggregated_alert_email(%data) if $data{data}; - } -} - -sub _send_aggregated_alert_email(%) { - my %data = @_; - Cobrand::set_lang_and_domain($data{cobrand}, $data{lang}, 1); - - $data{unsubscribe_url} = Cobrand::base_url_for_emails($data{cobrand}, $data{cobrand_data}) . '/A/' - . mySociety::AuthToken::store('alert', { id => $data{alert_id}, type => 'unsubscribe', email => $data{alert_email} } ); - my $template = "$FindBin::Bin/../templates/emails/$data{template}"; - if ($data{cobrand}) { - my $template_cobrand = "$FindBin::Bin/../templates/emails/$data{cobrand}/$data{template}"; - $template = $template_cobrand if -e $template_cobrand; - } - $template = File::Slurp::read_file($template); - my $sender = Cobrand::contact_email($data{cobrand}); - my $sender_name = Cobrand::contact_name($data{cobrand}); - (my $from = $sender) =~ s/team/fms-DO-NOT-REPLY/; # XXX - my $email = mySociety::Email::construct_email({ - _template_ => _($template), - _parameters_ => \%data, - From => [ $from, _($sender_name) ], - To => $data{alert_email}, - 'Message-ID' => sprintf('<alert-%s-%s@mysociety.org>', time(), unpack('h*', random_bytes(5, 1))), - }); - - my $result = mySociety::EmailUtil::send_email($email, $sender, $data{alert_email}); - if ($result == mySociety::EmailUtil::EMAIL_SUCCESS) { - dbh()->commit(); - } else { - dbh()->rollback(); - throw FixMyStreet::Alert::Error("Failed to send alert $data{alert_id}!"); - } -} - -sub generate_rss ($$$;$$$$) { - my ($type, $xsl, $qs, $db_params, $title_params, $cobrand, $http_q) = @_; - $db_params ||= []; - my $url = Cobrand::base_url($cobrand); - my $cobrand_data = Cobrand::extra_data($cobrand, $http_q); - my $q = dbh()->prepare('select * from alert_type where ref=?'); - $q->execute($type); - my $alert_type = $q->fetchrow_hashref; - my ($site_restriction, $site_id) = Cobrand::site_restriction($cobrand, $cobrand_data); - throw FixMyStreet::Alert::Error('Unknown alert type') unless $alert_type; - - # Do our own encoding - my $rss = new XML::RSS( version => '2.0', encoding => 'UTF-8', - stylesheet=> $xsl, encode_output => undef ); - $rss->add_module(prefix=>'georss', uri=>'http://www.georss.org/georss'); - - # Only apply a site restriction if the alert uses the problem table - $site_restriction = '' unless $alert_type->{item_table} eq 'problem'; - my $query = 'select * from ' . $alert_type->{item_table} . ' where ' - . ($alert_type->{head_table} ? $alert_type->{head_table}.'_id=? and ' : '') - . $alert_type->{item_where} . $site_restriction . ' order by ' - . $alert_type->{item_order}; - my $rss_limit = mySociety::Config::get('RSS_LIMIT'); - $query .= " limit $rss_limit" unless $type =~ /^all/; - $q = dbh()->prepare($query); - if ($query =~ /\?/) { - throw FixMyStreet::Alert::Error('Missing parameter') unless @$db_params; - $q->execute(@$db_params); - } else { - $q->execute(); - } - - while (my $row = $q->fetchrow_hashref) { - - $row->{name} ||= 'anonymous'; - - my $pubDate; - if ($row->{confirmed}) { - $row->{confirmed} =~ /^(\d\d\d\d)-(\d\d)-(\d\d) (\d\d):(\d\d):(\d\d)/; - $pubDate = mySociety::Locale::in_gb_locale { - strftime("%a, %d %b %Y %H:%M:%S %z", $6, $5, $4, $3, $2-1, $1-1900, -1, -1, 0) - }; - $row->{confirmed} = strftime("%e %B", $6, $5, $4, $3, $2-1, $1-1900, -1, -1, 0); - $row->{confirmed} =~ s/^\s+//; - $row->{confirmed} =~ s/^(\d+)/ordinal($1)/e if $mySociety::Locale::lang eq 'en-gb'; - } - - (my $title = _($alert_type->{item_title})) =~ s/{{(.*?)}}/$row->{$1}/g; - (my $link = $alert_type->{item_link}) =~ s/{{(.*?)}}/$row->{$1}/g; - (my $desc = _($alert_type->{item_description})) =~ s/{{(.*?)}}/$row->{$1}/g; - my $cobrand_url = Cobrand::url($cobrand, $url . $link, $http_q); - my %item = ( - title => ent($title), - link => $cobrand_url, - guid => $cobrand_url, - description => ent(ent($desc)) # Yes, double-encoded, really. - ); - $item{pubDate} = $pubDate if $pubDate; - $item{category} = $row->{category} if $row->{category}; - - my $display_photos = Cobrand::allow_photo_display($cobrand); - if ($display_photos && $row->{photo}) { - $item{description} .= ent("\n<br><img src=\"". Cobrand::url($cobrand, $url, $http_q) . "/photo?id=$row->{id}\">"); - } - my $recipient_name = Cobrand::contact_name($cobrand); - $item{description} .= ent("\n<br><a href='$cobrand_url'>" . - sprintf(_("Report on %s"), $recipient_name) . "</a>"); - - if ($row->{latitude} || $row->{longitude}) { - $item{georss} = { point => "$row->{latitude} $row->{longitude}" }; - } - $rss->add_item( %item ); - } - - my $row = {}; - if ($alert_type->{head_sql_query}) { - $q = dbh()->prepare($alert_type->{head_sql_query}); - if ($alert_type->{head_sql_query} =~ /\?/) { - $q->execute(@$db_params); - } else { - $q->execute(); - } - $row = $q->fetchrow_hashref; - } - foreach (keys %$title_params) { - $row->{$_} = $title_params->{$_}; - } - (my $title = _($alert_type->{head_title})) =~ s/{{(.*?)}}/$row->{$1}/g; - (my $link = $alert_type->{head_link}) =~ s/{{(.*?)}}/$row->{$1}/g; - (my $desc = _($alert_type->{head_description})) =~ s/{{(.*?)}}/$row->{$1}/g; - $rss->channel( - title => ent($title), link => "$url$link$qs", description => ent($desc), - language => 'en-gb' - ); - - my $out = $rss->as_string; - my $uri = Cobrand::url($cobrand, $ENV{SCRIPT_URI}, $http_q); - $out =~ s{<link>(.*?)</link>}{"<link>" . Cobrand::url($cobrand, $1, $http_q) . "</link><uri>$uri</uri>"}e; - - return $out; -} diff --git a/perllib/FixMyStreet/App.pm b/perllib/FixMyStreet/App.pm new file mode 100644 index 000000000..68bfc728b --- /dev/null +++ b/perllib/FixMyStreet/App.pm @@ -0,0 +1,407 @@ +package FixMyStreet::App; +use Moose; +use namespace::autoclean; + +use Catalyst::Runtime 5.80; +use FixMyStreet; +use FixMyStreet::Cobrand; +use Memcached; +use mySociety::Email; +use mySociety::EmailUtil; +use mySociety::Random qw(random_bytes); +use FixMyStreet::Map; + +use URI; +use URI::QueryParam; + +use Catalyst ( + 'Static::Simple', # + 'Unicode::Encoding', + 'Session', + 'Session::Store::DBIC', + 'Session::State::Cookie', # FIXME - we're using our own override atm + 'Authentication', + 'SmartURI', +); + +extends 'Catalyst'; + +our $VERSION = '0.01'; + +__PACKAGE__->config( + + # get the config from the core object + %{ FixMyStreet->config() }, + + name => 'FixMyStreet::App', + + encoding => 'UTF-8', + + # Disable deprecated behavior needed by old applications + disable_component_resolution_regex_fallback => 1, + + # Some generic stuff + default_view => 'Web', + + # Serve anything in web dir that is not a .cgi script + static => { # + include_path => [ FixMyStreet->path_to("web") . "" ], + ignore_extensions => ['cgi'], + }, + + 'Plugin::Session' => { # Catalyst::Plugin::Session::Store::DBIC + dbic_class => 'DB::Session', + expires => 3600 * 24 * 7 * 4, # 4 weeks + }, + + 'Plugin::Authentication' => { + default_realm => 'default', + default => { + credential => { # Catalyst::Authentication::Credential::Password + class => 'Password', + password_field => 'password', + password_type => 'self_check', + }, + store => { # Catalyst::Authentication::Store::DBIx::Class + class => 'DBIx::Class', + user_model => 'DB::User', + }, + }, + no_password => { # use post confirm etc + credential => { # Catalyst::Authentication::Credential::Password + class => 'Password', + password_type => 'none', + }, + store => { # Catalyst::Authentication::Store::DBIx::Class + class => 'DBIx::Class', + user_model => 'DB::User', + }, + }, + }, +); + +# Start the application +__PACKAGE__->setup(); + +# set up DB handle for old code +FixMyStreet->configure_mysociety_dbhandle; + +# disable debug logging unless in debug mode +__PACKAGE__->log->disable('debug') # + unless __PACKAGE__->debug; + +=head1 NAME + +FixMyStreet::App - Catalyst based application + +=head1 SYNOPSIS + + script/fixmystreet_app_server.pl + +=head1 DESCRIPTION + +FixMyStreet.com codebase + +=head1 METHODS + +=head2 cobrand + + $cobrand = $c->cobrand(); + +Returns the cobrand object. If not already determined this request finds it and +caches it to the stash. + +=cut + +sub cobrand { + my $c = shift; + return $c->stash->{cobrand} ||= $c->_get_cobrand(); +} + +sub _get_cobrand { + my $c = shift; + + my $host = $c->req->uri->host; + my $override_moniker = $c->get_override('cobrand_moniker'); + + my $cobrand_class = + $override_moniker + ? FixMyStreet::Cobrand->get_class_for_moniker($override_moniker) + : FixMyStreet::Cobrand->get_class_for_host($host); + + my $cobrand = $cobrand_class->new( { c => $c } ); + + return $cobrand; +} + +=head2 setup_request + + $cobrand = $c->setup_request(); + +Work out which cobrand we should be using. Set the environment correctly - eg +template paths, maps, languages etc, etc. + +=cut + +sub setup_request { + my $c = shift; + + $c->setup_dev_overrides(); + + my $cobrand = $c->cobrand; + + # append the cobrand templates to the include path + $c->stash->{additional_template_paths} = + [ $cobrand->path_to_web_templates->stringify ] + unless $cobrand->is_default; + + # work out which language to use + my $lang_override = $c->get_override('lang'); + my $host = $c->req->uri->host; + my $lang = + $lang_override ? $lang_override + : $host =~ /^en\./ ? 'en-gb' + : $host =~ /cy/ ? 'cy' + : undef; + + # set the language and the translation file to use - store it on stash + my $set_lang = $cobrand->set_lang_and_domain( + $lang, # language + 1, # return unicode + FixMyStreet->path_to('locale')->stringify # use locale directory + ); + $c->stash->{lang_code} = $set_lang; + + # debug + $c->log->debug( sprintf "Set lang to '%s' and cobrand to '%s'", + $set_lang, $cobrand->moniker ); + + $c->model('DB::Problem')->set_restriction( $cobrand->site_restriction() ); + + Memcached::set_namespace( FixMyStreet->config('BCI_DB_NAME') . ":" ); + + my $map = $host =~ /^osm\./ ? 'OSM' : $c->req->param('map_override'); + #if ($c->sessionid) { + # $map = $c->session->{map}; + # $map = undef unless $map eq 'OSM'; + #} + FixMyStreet::Map::set_map_class( $map ); + + return $c; +} + +=head2 setup_dev_overrides + + $c->setup_dev_overrides(); + +This is only run if STAGING_SITE is true. + +It is intended as an easy way to change the cobrand, language, map etc etc etc +without having to muck around with domain names and so on. The overrides are set +by passing _override_xxx parameters in the query. The values and stored in the +session and are used in preference to the defaults. + +All overrides can be easily cleared by setting the _override_clear_all parameter +to true. + +=cut + +sub setup_dev_overrides { + my $c = shift; + + # If not on STAGING_SITE bail out + return unless $c->config->{STAGING_SITE}; + + # Extract all the _override_xxx parameters + my %params = %{ $c->req->parameters }; + delete $params{$_} for grep { !m{^_override_} } keys %params; + + # stop if there is nothing to add + return 1 unless scalar keys %params; + + # Check to see if we should clear all + if ( $params{_override_clear_all} ) { + delete $c->session->{overrides}; + return; + } + + # check for all the other _override params and set their values + my $overrides = $c->session->{overrides} ||= {}; + foreach my $raw_key ( keys %params ) { + my ($key) = $raw_key =~ m{^_override_(.*)$}; + $overrides->{$key} = $params{$raw_key}; + } + + return $overrides; +} + +=head2 get_override + + $value = $c->get_override( 'cobrand_moniker' ); + +Checks the overrides for the value given and returns it if found, undef if not. + +Always returns undef unless on a staging site (avoids autovivifying overrides +hash in session and so creating a session for all users). + +=cut + +sub get_override { + my ( $c, $key ) = @_; + return unless $c->config->{STAGING_SITE}; + return $c->session->{overrides}->{$key}; +} + +=head2 send_email + + $email_sent = $c->send_email( 'email_template.txt', $extra_stash_values ); + +Send an email by filling in the given template with values in the stash. + +You can specify extra values to those already in the stash by passing a hashref +as the second argument. + +The stash (or extra_stash_values) keys 'to', 'from' and 'subject' are used to +set those fields in the email if they are present. + +If a 'from' is not specified then the default from the config is used. + +=cut + +sub send_email { + my $c = shift; + my $template = shift; + my $extra_stash_values = shift || {}; + + my $sender = $c->cobrand->contact_email; + my $sender_name = $c->cobrand->contact_name; + $sender =~ s/team/fms-DO-NOT-REPLY/; + + # create the vars to pass to the email template + my $vars = { + from => [ $sender, _($sender_name) ], + %{ $c->stash }, + %$extra_stash_values, + additional_template_paths => [ + FixMyStreet->path_to( 'templates', 'email', $c->cobrand->moniker, $c->stash->{lang_code} )->stringify, + FixMyStreet->path_to( 'templates', 'email', $c->cobrand->moniker )->stringify, + ] + }; + + # render the template + my $content = $c->view('Email')->render( $c, $template, $vars ); + + # create an email - will parse headers out of content + my $email = Email::Simple->new($content); + $email->header_set( ucfirst($_), $vars->{$_} ) + for grep { $vars->{$_} } qw( to from subject); + + # pass the email into mySociety::Email to construct the on the wire 7bit + # format - this should probably happen in the transport instead but hohum. + my $email_text = mySociety::Locale::in_gb_locale { mySociety::Email::construct_email( + { + _template_ => $email->body, # will get line wrapped + _parameters_ => {}, + $email->header_pairs + } + ) }; + + # send the email + $c->model('EmailSend')->send($email_text); + + return $email; +} + +sub send_email_cron { + my ( $c, $params, $env_from, $env_to, $nomail ) = @_; + + $params->{'Message-ID'} = sprintf('<fms-cron-%s-%s@mysociety.org>', time(), + unpack('h*', random_bytes(5, 1)) + ); + + my $email = mySociety::Locale::in_gb_locale { mySociety::Email::construct_email($params) }; + + if ( FixMyStreet->test_mode ) { + my $sender = Email::Send->new({ mailer => 'Test' }); + $sender->send( $email ); + return 0; + } elsif (!$nomail) { + return mySociety::EmailUtil::send_email( $email, $env_from, @$env_to ); + } else { + print $email; + return 1; # Failure + } +} + +=head2 uri_with + + $uri = $c->uri_with( ... ); + +Simply forwards on to $c->req->uri_with - this is a common typo I make! + +=cut + +sub uri_with { + my $c = shift; + return $c->req->uri_with(@_); +} + +=head2 uri_for + + $uri = $c->uri_for( ... ); + +Like C<uri_for> except that it passes the uri to the cobrand to be altered if +needed. + +=cut + +sub uri_for { + my $c = shift; + my @args = @_; + + my $uri = $c->next::method(@args); + + my $cobranded_uri = $c->cobrand->uri($uri); + + # note that the returned uri may be a string not an object (eg cities) + return $cobranded_uri; +} + +=head2 uri_for_email + + $uri = $c->uri_for_email( ... ); + +Like C<uri_for> except that it checks the cobrand for an email specific url base +and uses that. + +=cut + +sub uri_for_email { + my $c = shift; + my @args = @_; + + my $normal_uri = $c->uri_for(@_)->absolute; + my $base = $c->cobrand->base_url_with_lang( 1 ); + + my $email_uri = $base . $normal_uri->path_query; + + return URI->new($email_uri); +} + +sub finalize { + my $c = shift; + $c->next::method(@_); + + # cobrand holds on to a reference to $c so we want to + # get git rid of this to stop circular references and + # memory leaks + delete $c->stash->{cobrand}; +} + +=head1 SEE ALSO + +L<FixMyStreet::App::Controller::Root>, L<Catalyst> + +=cut + +1; diff --git a/perllib/FixMyStreet/App/Controller/Admin.pm b/perllib/FixMyStreet/App/Controller/Admin.pm new file mode 100644 index 000000000..fbd50a973 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Admin.pm @@ -0,0 +1,814 @@ +package FixMyStreet::App::Controller::Admin; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use POSIX qw(strftime strcoll); +use Digest::MD5 qw(md5_hex); + +=head1 NAME + +FixMyStreet::App::Controller::Admin- Catalyst Controller + +=head1 DESCRIPTION + +Admin pages + +=head1 METHODS + +=cut + +=head2 summary + +Redirect to index page. There to make the allowed pages stuff neater + +=cut + +sub begin : Private { + my ( $self, $c ) = @_; + + $c->uri_disposition('relative'); +} + +sub summary : Path( 'summary' ) : Args(0) { + my ( $self, $c ) = @_; + $c->go( 'index' ); +} + +=head2 index + +Displays some summary information for the requests. + +=cut + +sub index : Path : Args(0) { + my ( $self, $c ) = @_; + + $c->forward('check_page_allowed'); + + my ( $sql_restriction, $id, $site_restriction ) = $c->cobrand->site_restriction(); + + my $problems = $c->cobrand->problems->summary_count; + + my %prob_counts = + map { $_->state => $_->get_column('state_count') } $problems->all; + + %prob_counts = + map { $_ => $prob_counts{$_} || 0 } + qw(confirmed fixed unconfirmed hidden partial); + $c->stash->{problems} = \%prob_counts; + $c->stash->{total_problems_live} = + $prob_counts{confirmed} + $prob_counts{fixed}; + $c->stash->{total_problems_users} = $c->cobrand->problems->unique_users; + + my $comments = $c->model('DB::Comment')->summary_count( $site_restriction ); + + my %comment_counts = + map { $_->state => $_->get_column('state_count') } $comments->all; + + $c->stash->{comments} = \%comment_counts; + + my $alerts = $c->model('DB::Alert')->summary_count( $c->cobrand->restriction ); + + my %alert_counts = + map { $_->confirmed => $_->get_column('confirmed_count') } $alerts->all; + + $alert_counts{0} ||= 0; + $alert_counts{1} ||= 0; + + $c->stash->{alerts} = \%alert_counts; + + my $contacts = $c->model('DB::Contact')->summary_count( $c->cobrand->contact_restriction ); + + my %contact_counts = + map { $_->confirmed => $_->get_column('confirmed_count') } $contacts->all; + + $contact_counts{0} ||= 0; + $contact_counts{1} ||= 0; + $contact_counts{total} = $contact_counts{0} + $contact_counts{1}; + + $c->stash->{contacts} = \%contact_counts; + + my $questionnaires = $c->model('DB::Questionnaire')->summary_count( $c->cobrand->restriction ); + + my %questionnaire_counts = map { + $_->get_column('answered') => $_->get_column('questionnaire_count') + } $questionnaires->all; + $questionnaire_counts{1} ||= 0; + $questionnaire_counts{0} ||= 0; + + $questionnaire_counts{total} = + $questionnaire_counts{0} + $questionnaire_counts{1}; + $c->stash->{questionnaires_pc} = + $questionnaire_counts{total} + ? sprintf( '%.1f', + $questionnaire_counts{1} / $questionnaire_counts{total} * 100 ) + : _('n/a'); + $c->stash->{questionnaires} = \%questionnaire_counts; + + $c->stash->{categories} = $c->cobrand->problems->categories_summary(); + + return 1; +} + +sub timeline : Path( 'timeline' ) : Args(0) { + my ($self, $c) = @_; + + $c->forward('check_page_allowed'); + + my ( $sql_restriction, $id, $site_restriction ) = $c->cobrand->site_restriction(); + my %time; + + $c->model('DB')->schema->storage->sql_maker->quote_char( '"' ); + + my $probs = $c->cobrand->problems->timeline; + + foreach ($probs->all) { + push @{$time{$_->created->epoch}}, { type => 'problemCreated', date => $_->created_local, obj => $_ }; + push @{$time{$_->confirmed->epoch}}, { type => 'problemConfirmed', date => $_->confirmed_local, obj => $_ } if $_->confirmed; + push @{$time{$_->whensent->epoch}}, { type => 'problemSent', date => $_->whensent_local, obj => $_ } if $_->whensent; + } + + my $questionnaires = $c->model('DB::Questionnaire')->timeline( $c->cobrand->restriction ); + + foreach ($questionnaires->all) { + push @{$time{$_->whensent->epoch}}, { type => 'quesSent', date => $_->whensent_local, obj => $_ }; + push @{$time{$_->whenanswered->epoch}}, { type => 'quesAnswered', date => $_->whenanswered_local, obj => $_ } if $_->whenanswered; + } + + my $updates = $c->model('DB::Comment')->timeline( $site_restriction ); + + foreach ($updates->all) { + push @{$time{$_->created->epoch}}, { type => 'update', date => $_->created_local, obj => $_} ; + } + + my $alerts = $c->model('DB::Alert')->timeline_created( $c->cobrand->restriction ); + + foreach ($alerts->all) { + push @{$time{$_->whensubscribed->epoch}}, { type => 'alertSub', date => $_->whensubscribed_local, obj => $_ }; + } + + $alerts = $c->model('DB::Alert')->timeline_disabled( $c->cobrand->restriction ); + + foreach ($alerts->all) { + push @{$time{$_->whendisabled->epoch}}, { type => 'alertDel', date => $_->whendisabled_local, obj => $_ }; + } + + $c->model('DB')->schema->storage->sql_maker->quote_char( '' ); + + $c->stash->{time} = \%time; + + return 1; +} + +sub questionnaire : Path('questionnaire') : Args(0) { + my ( $self, $c ) = @_; + + $c->forward('check_page_allowed'); + + my $questionnaires = $c->model('DB::Questionnaire')->search( + { whenanswered => \'is not null' }, { group_by => [ 'ever_reported' ], select => [ 'ever_reported', { count => 'me.id' } ], as => [qw/reported questionnaire_count/] } + ); + + + my %questionnaire_counts = map { $_->get_column( 'reported' ) => $_->get_column( 'questionnaire_count' ) } $questionnaires->all; + $questionnaire_counts{1} ||= 0; + $questionnaire_counts{0} ||= 0; + $questionnaire_counts{total} = $questionnaire_counts{0} + $questionnaire_counts{1}; + $c->stash->{questionnaires} = \%questionnaire_counts; + + $c->stash->{state_changes_count} = $c->model('DB::Questionnaire')->search( + { whenanswered => \'is not null' } + )->count; + $c->stash->{state_changes} = $c->model('DB::Questionnaire')->search( + { whenanswered => \'is not null' }, + { + group_by => [ 'old_state', 'new_state' ], + columns => [ 'old_state', 'new_state', { c => { count => 'id' } } ], + }, + ); + + return 1; +} + +sub council_list : Path('council_list') : Args(0) { + my ( $self, $c ) = @_; + + $c->forward('check_page_allowed'); + + my $edit_activity = $c->model('DB::ContactsHistory')->search( + undef, + { + select => [ 'editor', { count => 'contacts_history_id', -as => 'c' } ], + group_by => ['editor'], + order_by => { -desc => 'c' } + } + ); + + $c->stash->{edit_activity} = $edit_activity; + + my @area_types = $c->cobrand->area_types; + my $areas = mySociety::MaPit::call('areas', \@area_types); + + my @councils_ids = sort { strcoll($areas->{$a}->{name}, $areas->{$b}->{name}) } keys %$areas; + @councils_ids = $c->cobrand->filter_all_council_ids_list( @councils_ids ); + + my $contacts = $c->model('DB::Contact')->search( + undef, + { + select => [ 'area_id', { count => 'id' }, { count => \'case when deleted then 1 else null end' }, + { count => \'case when confirmed then 1 else null end' } ], + as => [qw/area_id c deleted confirmed/], + group_by => [ 'area_id' ], + result_class => 'DBIx::Class::ResultClass::HashRefInflator' + } + ); + + my %council_info = map { $_->{area_id} => $_ } $contacts->all; + + my @no_info = grep { !$council_info{$_} } @councils_ids; + my @one_plus_deleted = grep { $council_info{$_} && $council_info{$_}->{deleted} } @councils_ids; + my @unconfirmeds = grep { $council_info{$_} && !$council_info{$_}->{deleted} && $council_info{$_}->{confirmed} != $council_info{$_}->{c} } @councils_ids; + my @all_confirmed = grep { $council_info{$_} && !$council_info{$_}->{deleted} && $council_info{$_}->{confirmed} == $council_info{$_}->{c} } @councils_ids; + + $c->stash->{areas} = $areas; + $c->stash->{counts} = \%council_info; + $c->stash->{no_info} = \@no_info; + $c->stash->{one_plus_deleted} = \@one_plus_deleted; + $c->stash->{unconfirmeds} = \@unconfirmeds; + $c->stash->{all_confirmed} = \@all_confirmed; + + return 1; +} + +sub council_contacts : Path('council_contacts') : Args(1) { + my ( $self, $c, $area_id ) = @_; + + $c->forward('check_page_allowed'); + + my $posted = $c->req->param('posted') || ''; + $c->stash->{area_id} = $area_id; + + $c->forward( 'get_token' ); + + if ( $posted ) { + $c->log->debug( 'posted' ); + $c->forward('update_contacts'); + } + + $c->forward('display_contacts'); + + return 1; +} + +sub update_contacts : Private { + my ( $self, $c ) = @_; + + my $posted = $c->req->param('posted'); + my $editor = $c->req->remote_user || _('*unknown*'); + + if ( $posted eq 'new' ) { + $c->forward('check_token'); + + my $category = $self->trim( $c->req->param( 'category' ) ); + my $email = $self->trim( $c->req->param( 'email' ) ); + + $category = 'Empty property' if $c->cobrand->moniker eq 'emptyhomes'; + + my $contact = $c->model('DB::Contact')->find_or_new( + { + area_id => $c->stash->{area_id}, + category => $category, + } + ); + + $contact->email( $email ); + $contact->confirmed( $c->req->param('confirmed') ? 1 : 0 ); + $contact->deleted( $c->req->param('deleted') ? 1 : 0 ); + $contact->note( $c->req->param('note') ); + $contact->whenedited( \'ms_current_timestamp()' ); + $contact->editor( $editor ); + + if ( $contact->in_storage ) { + $c->stash->{updated} = _('Values updated'); + + # NB: History is automatically stored by a trigger in the database + $contact->update; + } else { + $c->stash->{updated} = _('New category contact added'); + $contact->insert; + } + + } elsif ( $posted eq 'update' ) { + $c->forward('check_token'); + + my @categories = $c->req->param('confirmed'); + + my $contacts = $c->model('DB::Contact')->search( + { + area_id => $c->stash->{area_id}, + category => { -in => \@categories }, + } + ); + + $contacts->update( + { + confirmed => 1, + whenedited => \'ms_current_timestamp()', + note => 'Confirmed', + editor => $editor, + } + ); + + $c->stash->{updated} = _('Values updated'); + } +} + +sub display_contacts : Private { + my ( $self, $c ) = @_; + + $c->forward('setup_council_details'); + + my $area_id = $c->stash->{area_id}; + + my $contacts = $c->model('DB::Contact')->search( + { area_id => $area_id }, + { order_by => ['category'] } + ); + + $c->stash->{contacts} = $contacts; + + if ( $c->req->param('text') && $c->req->param('text') == 1 ) { + $c->stash->{template} = 'admin/council_contacts.txt'; + $c->res->content_type('text/plain; charset=utf-8'); + return 1; + } + + return 1; +} + +sub setup_council_details : Private { + my ( $self, $c ) = @_; + + my $area_id = $c->stash->{area_id}; + + my $mapit_data = mySociety::MaPit::call('area', $area_id); + + $c->stash->{council_name} = $mapit_data->{name}; + + my $example_postcode = mySociety::MaPit::call('area/example_postcode', $area_id); + + if ($example_postcode && ! ref $example_postcode) { + $c->stash->{example_pc} = $example_postcode; + } + + return 1; +} + +sub council_edit_all : Path('council_edit') { + my ( $self, $c, $area_id, @category ) = @_; + my $category = join( '/', @category ); + $c->go( 'council_edit', [ $area_id, $category ] ); +} + +sub council_edit : Path('council_edit') : Args(2) { + my ( $self, $c, $area_id, $category ) = @_; + + $c->forward('check_page_allowed'); + + $c->stash->{area_id} = $area_id; + + $c->forward( 'get_token' ); + $c->forward('setup_council_details'); + + my $contact = $c->model('DB::Contact')->search( + { + area_id => $area_id, + category => $category + } + )->first; + + $c->stash->{contact} = $contact; + + my $history = $c->model('DB::ContactsHistory')->search( + { + area_id => $area_id, + category => $category + }, + { + order_by => ['contacts_history_id'] + }, + ); + + $c->stash->{history} = $history; + + return 1; +} + +sub search_reports : Path('search_reports') { + my ( $self, $c ) = @_; + + $c->forward('check_page_allowed'); + + if (my $search = $c->req->param('search')) { + $c->stash->{searched} = 1; + + my ( $site_res_sql, $site_key, $site_restriction ) = $c->cobrand->site_restriction; + + my $search_n = 0; + $search_n = int($search) if $search =~ /^\d+$/; + + my $like_search = "%$search%"; + + # when DBIC creates the join it does 'JOIN users user' in the + # SQL which makes PostgreSQL unhappy as user is a reserved + # word, hence we need to quote this SQL. However, the quoting + # makes PostgreSQL unhappy elsewhere so we only want to do + # it for this query and then switch it off afterwards. + $c->model('DB')->schema->storage->sql_maker->quote_char( '"' ); + + my $problems = $c->cobrand->problems->search( + { + -or => [ + 'me.id' => $search_n, + 'user.email' => { ilike => $like_search }, + 'me.name' => { ilike => $like_search }, + title => { ilike => $like_search }, + detail => { ilike => $like_search }, + council => { like => $like_search }, + cobrand_data => { like => $like_search }, + ] + }, + { + prefetch => 'user', + order_by => [\"(state='hidden')",'created'] + } + ); + + $c->stash->{problems} = [ $problems->all ]; + + + $c->stash->{edit_council_contacts} = 1 + if ( grep {$_ eq 'councilcontacts'} keys %{$c->stash->{allowed_pages}}); + + my $updates = $c->model('DB::Comment')->search( + { + -or => [ + 'me.id' => $search_n, + 'problem.id' => $search_n, + 'user.email' => { ilike => $like_search }, + 'me.name' => { ilike => $like_search }, + text => { ilike => $like_search }, + 'me.cobrand_data' => { ilike => $like_search }, + %{ $site_restriction }, + ] + }, + { + -select => [ 'me.*', qw/problem.council problem.state/ ], + prefetch => [qw/user problem/], + order_by => [\"(me.state='hidden')",\"(problem.state='hidden')",'me.created'] + } + ); + + $c->stash->{updates} = [ $updates->all ]; + + # Switch quoting back off. See above for explanation of this. + $c->model('DB')->schema->storage->sql_maker->quote_char( '' ); + } +} + +sub report_edit : Path('report_edit') : Args(1) { + my ( $self, $c, $id ) = @_; + + my ( $site_res_sql, $site_key, $site_restriction ) = $c->cobrand->site_restriction; + + my $problem = $c->cobrand->problems->search( + { + id => $id, + } + )->first; + + $c->detach( '/page_error_404_not_found', + [ _('The requested URL was not found on this server.') ] ) + unless $problem; + + $c->stash->{problem} = $problem; + + $c->forward('get_token'); + $c->forward('check_page_allowed'); + + $c->stash->{updates} = + [ $c->model('DB::Comment') + ->search( { problem_id => $problem->id }, { order_by => 'created' } ) + ->all ]; + + if ( $c->req->param('resend') ) { + $c->forward('check_token'); + + $problem->whensent(undef); + $problem->update(); + $c->stash->{status_message} = + '<p><em>' . _('That problem will now be resent.') . '</em></p>'; + + $c->forward( 'log_edit', [ $id, 'problem', 'resend' ] ); + } + elsif ( $c->req->param('submit') ) { + $c->forward('check_token'); + + my $done = 0; + my $edited = 0; + + my $new_state = $c->req->param('state'); + my $old_state = $problem->state; + if ( $new_state eq 'confirmed' + && $problem->state eq 'unconfirmed' + && $c->cobrand->moniker eq 'emptyhomes' ) + { + $c->stash->{status_message} = + '<p><em>' + . _('I am afraid you cannot confirm unconfirmed reports.') + . '</em></p>'; + $done = 1; + } + + # do this here so before we update the values in problem + if ( $c->req->param('anonymous') ne $problem->anonymous + || $c->req->param('name') ne $problem->name + || $c->req->param('email') ne $problem->user->email + || $c->req->param('title') ne $problem->title + || $c->req->param('detail') ne $problem->detail ) + { + $edited = 1; + } + + $problem->anonymous( $c->req->param('anonymous') ); + $problem->title( $c->req->param('title') ); + $problem->detail( $c->req->param('detail') ); + $problem->state( $c->req->param('state') ); + $problem->name( $c->req->param('name') ); + + if ( $c->req->param('email') ne $problem->user->email ) { + my $user = $c->model('DB::User')->find_or_create( + { email => $c->req->param('email') } + ); + + $user->insert unless $user->in_storage; + $problem->user( $user ); + } + + if ( $c->req->param('remove_photo') ) { + $problem->photo(undef); + } + + if ( $new_state ne $old_state ) { + $problem->lastupdate( \'ms_current_timestamp()' ); + } + + if ( $new_state eq 'confirmed' and $old_state eq 'unconfirmed' ) { + $problem->confirmed( \'ms_current_timestamp()' ); + } + + if ($done) { + $problem->discard_changes; + } + else { + $problem->update; + + if ( $new_state ne $old_state ) { + $c->forward( 'log_edit', [ $id, 'problem', 'state_change' ] ); + } + if ($edited) { + $c->forward( 'log_edit', [ $id, 'problem', 'edit' ] ); + } + + $c->stash->{status_message} = + '<p><em>' . _('Updated!') . '</em></p>'; + + # do this here otherwise lastupdate and confirmed times + # do not display correctly + $problem->discard_changes; + } + } + + return 1; +} + +=head2 set_allowed_pages + +Sets up the allowed_pages stash entry for checking if the current page is +available in the current cobrand. + +=cut + +sub set_allowed_pages : Private { + my ( $self, $c ) = @_; + + my $pages = $c->cobrand->admin_pages; + + if( !$pages ) { + $pages = { + 'summary' => [_('Summary'), 0], + 'council_list' => [_('Council contacts'), 1], + 'search_reports' => [_('Search Reports'), 2], + 'timeline' => [_('Timeline'), 3], + 'questionnaire' => [_('Survey Results'), 4], + 'council_contacts' => [undef, undef], + 'council_edit' => [undef, undef], + 'report_edit' => [undef, undef], + 'update_edit' => [undef, undef], + } + } + + my @allowed_links = sort {$pages->{$a}[1] <=> $pages->{$b}[1]} grep {$pages->{$_}->[0] } keys %$pages; + + $c->stash->{allowed_pages} = $pages; + $c->stash->{allowed_links} = \@allowed_links; + + return 1; +} + +=item get_token + +Generate a token based on user and secret + +=cut + +sub get_token : Private { + my ( $self, $c ) = @_; + + my $secret = $c->model('DB::Secret')->search()->first; + + my $user = $c->req->remote_user(); + $user ||= ''; + + my $token = md5_hex(($user . $secret->secret)); + + $c->stash->{token} = $token; + + return 1; +} + +=item check_token + +Check that a token has been set on a request and it's the correct token. If +not then display 404 page + +=cut + +sub check_token : Private { + my ( $self, $c ) = @_; + + if ( $c->req->param('token' ) ne $c->stash->{token} ) { + $c->detach( '/page_error_404_not_found', [ _('The requested URL was not found on this server.') ] ); + } + + return 1; +} + +=item log_edit + + $c->forward( 'log_edit', [ $object_id, $object_type, $action_performed ] ); + +Adds an entry into the admin_log table using the current remote_user. + +=cut + +sub log_edit : Private { + my ( $self, $c, $id, $object_type, $action ) = @_; + $c->model('DB::AdminLog')->create( + { + admin_user => ( $c->req->remote_user() || '' ), + object_type => $object_type, + action => $action, + object_id => $id, + } + )->insert(); +} + +sub update_edit : Path('update_edit') : Args(1) { + my ( $self, $c, $id ) = @_; + + my ( $site_res_sql, $site_key, $site_restriction ) = + $c->cobrand->site_restriction; + my $update = $c->model('DB::Comment')->search( + { + id => $id, + %{$site_restriction}, + } + )->first; + + $c->detach( '/page_error_404_not_found', + [ _('The requested URL was not found on this server.') ] ) + unless $update; + + $c->forward('get_token'); + $c->forward('check_page_allowed'); + + $c->stash->{update} = $update; + + my $status_message = ''; + if ( $c->req->param('submit') ) { + $c->forward('check_token'); + + my $old_state = $update->state; + my $new_state = $c->req->param('state'); + + my $edited = 0; + + # $update->name can be null which makes ne unhappy + my $name = $update->name || ''; + + if ( $c->req->param('name') ne $name + || $c->req->param('email') ne $update->user->email + || $c->req->param('anonymous') ne $update->anonymous + || $c->req->param('text') ne $update->text ){ + $edited = 1; + } + + if ( $c->req->param('remove_photo') ) { + $update->photo(undef); + } + + $update->name( $c->req->param('name') || '' ); + $update->text( $c->req->param('text') ); + $update->anonymous( $c->req->param('anonymous') ); + $update->state( $c->req->param('state') ); + + if ( $c->req->param('email') ne $update->user->email ) { + my $user = + $c->model('DB::User') + ->find_or_create( { email => $c->req->param('email') } ); + + $user->insert unless $user->in_storage; + $update->user($user); + } + + $update->update; + + $status_message = '<p><em>' . _('Updated!') . '</em></p>'; + + # If we're hiding an update, see if it marked as fixed and unfix if so + if ( $new_state eq 'hidden' && $update->mark_fixed ) { + if ( $update->problem->state eq 'fixed' ) { + $update->problem->state('confirmed'); + $update->problem->update; + } + + $status_message .= + '<p><em>' . _('Problem marked as open.') . '</em></p>'; + } + + if ( $new_state ne $old_state ) { + $c->forward( 'log_edit', + [ $update->id, 'update', 'state_change' ] ); + } + + if ($edited) { + $c->forward( 'log_edit', [ $update->id, 'update', 'edit' ] ); + } + + } + $c->stash->{status_message} = $status_message; + + return 1; +} + +sub check_page_allowed : Private { + my ( $self, $c ) = @_; + + $c->forward('set_allowed_pages'); + + (my $page = $c->req->action) =~ s#admin/?##; + + $page ||= 'summary'; + + if ( !grep { $_ eq $page } keys %{ $c->stash->{allowed_pages} } ) { + $c->detach( '/page_error_404_not_found', [ _('The requested URL was not found on this server.') ] ); + } + + return 1; +} + +sub trim { + my $self = shift; + my $e = shift; + $e =~ s/^\s+//; + $e =~ s/\s+$//; + return $e; +} + +=head1 AUTHOR + +Struan Donald + +=head1 LICENSE + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Alert.pm b/perllib/FixMyStreet/App/Controller/Alert.pm new file mode 100644 index 000000000..ff92a7d2d --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Alert.pm @@ -0,0 +1,529 @@ +package FixMyStreet::App::Controller::Alert; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use mySociety::EmailUtil qw(is_valid_email); + +=head1 NAME + +FixMyStreet::App::Controller::Alert - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + +=head2 alert + +Show the alerts page + +=cut + +sub index : Path('') : Args(0) { + my ( $self, $c ) = @_; + + $c->stash->{cobrand_form_elements} = $c->cobrand->form_elements('alerts'); + + unless ( $c->req->referer && $c->req->referer =~ /fixmystreet\.com/ ) { + $c->forward( 'add_recent_photos', [10] ); + } +} + +sub list : Path('list') : Args(0) { + my ( $self, $c ) = @_; + + return + unless $c->forward('setup_request') + && $c->forward('prettify_pc') + && $c->forward('determine_location') + && $c->forward( 'add_recent_photos', [5] ) + && $c->forward('setup_council_rss_feeds') + && $c->forward('setup_coordinate_rss_feeds'); +} + +=head2 subscribe + +Target for subscribe form + +=cut + +sub subscribe : Path('subscribe') : Args(0) { + my ( $self, $c ) = @_; + + $c->detach('rss') if $c->req->param('rss'); + + # if it exists then it's been submitted so we should + # go to subscribe email and let it work out the next step + $c->detach('subscribe_email') + if exists $c->req->params->{'rznvy'} || $c->req->params->{'alert'}; + + $c->go('updates') if $c->req->params->{'id'}; + + # shouldn't get to here but if we have then do something sensible + $c->go('index'); +} + +=head2 rss + +Redirects to relevant RSS feed + +=cut + +sub rss : Private { + my ( $self, $c ) = @_; + my $feed = $c->req->params->{feed}; + + unless ($feed) { + $c->stash->{errors} = [ _('Please select the feed you want') ]; + $c->go('list'); + } + + my $url; + if ( $feed =~ /^area:(?:\d+:)+(.*)$/ ) { + ( my $id = $1 ) =~ tr{:_}{/+}; + $url = $c->cobrand->base_url() . '/rss/area/' . $id; + $c->res->redirect($url); + } + elsif ( $feed =~ /^(?:council|ward):(?:\d+:)+(.*)$/ ) { + ( my $id = $1 ) =~ tr{:_}{/+}; + $url = $c->cobrand->base_url() . '/rss/reports/' . $id; + $c->res->redirect($url); + } + elsif ( $feed =~ /^local:([\d\.-]+):([\d\.-]+)$/ ) { + $url = $c->cobrand->base_url() . '/rss/l/' . $1 . ',' . $2; + $c->res->redirect($url); + } + else { + $c->stash->{errors} = [ _('Illegal feed selection') ]; + $c->go('list'); + } +} + +=head2 subscribe_email + +Sign up to email alerts + +=cut + +sub subscribe_email : Private { + my ( $self, $c ) = @_; + + $c->stash->{errors} = []; + $c->forward('process_user'); + + my $type = $c->req->param('type'); + push @{ $c->stash->{errors} }, _('Please select the type of alert you want') + if $type && $type eq 'local' && !$c->req->param('feed'); + if (@{ $c->stash->{errors} }) { + $c->go('updates') if $type && $type eq 'updates'; + $c->go('list') if $type && $type eq 'local'; + $c->go('index'); + } + + if ( $type eq 'updates' ) { + $c->forward('set_update_alert_options'); + } + elsif ( $type eq 'local' ) { + $c->forward('set_local_alert_options'); + } + else { + $c->detach( '/page_error_404_not_found', [ 'Invalid type' ] ); + } + + $c->forward('create_alert'); + if ( $c->stash->{alert}->confirmed ) { + $c->stash->{confirm_type} = 'created'; + $c->stash->{template} = 'tokens/confirm_alert.html'; + } else { + $c->forward('send_confirmation_email'); + } +} + +sub updates : Path('updates') : Args(0) { + my ( $self, $c ) = @_; + + $c->stash->{email} = $c->req->param('rznvy'); + $c->stash->{problem_id} = $c->req->param('id'); + $c->stash->{cobrand_form_elements} = $c->cobrand->form_elements('alerts'); +} + +=head2 confirm + +Confirm signup to or unsubscription from an alert. Forwarded here from Tokens. + +=cut + +sub confirm : Private { + my ( $self, $c ) = @_; + + my $alert = $c->stash->{alert}; + + if ( $c->stash->{confirm_type} eq 'subscribe' ) { + $alert->confirm(); + } + elsif ( $c->stash->{confirm_type} eq 'unsubscribe' ) { + $alert->disable(); + } +} + +=head2 create_alert + +Take the alert options from the stash and use these to create a new +alert. If it finds an existing alert that's the same then use that + +=cut + +sub create_alert : Private { + my ( $self, $c ) = @_; + + my $options = $c->stash->{alert_options}; + + my $alert = $c->model('DB::Alert')->find($options); + + unless ($alert) { + $options->{cobrand} = $c->cobrand->moniker(); + $options->{cobrand_data} = $c->cobrand->extra_update_data(); + $options->{lang} = $c->stash->{lang_code}; + + $alert = $c->model('DB::Alert')->new($options); + $alert->insert(); + } + + $alert->confirm() if $c->user && $c->user->id == $alert->user->id; + + $c->stash->{alert} = $alert; +} + +=head2 set_update_alert_options + +Set up the options in the stash required to create a problem update alert + +=cut + +sub set_update_alert_options : Private { + my ( $self, $c ) = @_; + + my $report_id = $c->req->param('id'); + + my $options = { + user => $c->stash->{alert_user}, + alert_type => 'new_updates', + parameter => $report_id, + }; + + $c->stash->{alert_options} = $options; +} + +=head2 set_local_alert_options + +Set up the options in the stash required to create a local problems alert + +=cut + +sub set_local_alert_options : Private { + my ( $self, $c ) = @_; + + my $feed = $c->req->param('feed'); + + my ( $type, @params, $alert ); + if ( $feed =~ /^area:(?:\d+:)?(\d+)/ ) { + $type = 'area_problems'; + push @params, $1; + } + elsif ( $feed =~ /^council:(\d+)/ ) { + $type = 'council_problems'; + push @params, $1, $1; + } + elsif ( $feed =~ /^ward:(\d+):(\d+)/ ) { + $type = 'ward_problems'; + push @params, $1, $2; + } + elsif ( $feed =~ + m{ \A local: ( [\+\-]? \d+ \.? \d* ) : ( [\+\-]? \d+ \.? \d* ) }xms ) + { + $type = 'local_problems'; + push @params, $2, $1; # Note alert parameters are lon,lat + } + + my $options = { + user => $c->stash->{alert_user}, + alert_type => $type + }; + + if ( scalar @params == 1 ) { + $options->{parameter} = $params[0]; + } + elsif ( scalar @params == 2 ) { + $options->{parameter} = $params[0]; + $options->{parameter2} = $params[1]; + } + + $c->stash->{alert_options} = $options; +} + +=head2 send_confirmation_email + +Generate a token and send out an alert subscription confirmation email and +then display confirmation page. + +=cut + +sub send_confirmation_email : Private { + my ( $self, $c ) = @_; + + my $token = $c->model("DB::Token")->create( + { + scope => 'alert', + data => { + id => $c->stash->{alert}->id, + type => 'subscribe', + email => $c->stash->{alert}->user->email + } + } + ); + + $c->stash->{token_url} = $c->uri_for_email( '/A', $token->token ); + + $c->send_email( 'alert-confirm.txt', { to => $c->stash->{alert}->user->email } ); + + $c->stash->{email_type} = 'alert'; + $c->stash->{template} = 'email_sent.html'; +} + +=head2 prettify_pc + +This will canonicalise and prettify the postcode and stick a pretty_pc and pretty_pc_text in the stash. + +=cut + +sub prettify_pc : Private { + my ( $self, $c ) = @_; + + my $pretty_pc = $c->req->params->{'pc'}; + + if ( mySociety::PostcodeUtil::is_valid_postcode( $c->req->params->{'pc'} ) ) + { + $pretty_pc = mySociety::PostcodeUtil::canonicalise_postcode( + $c->req->params->{'pc'} ); + my $pretty_pc_text = $pretty_pc; + $pretty_pc_text =~ s/ //g; + $c->stash->{pretty_pc_text} = $pretty_pc_text; + } + + $c->stash->{pretty_pc} = $pretty_pc; + + return 1; +} + +=head2 process_user + +Fetch/check email address + +=cut + +sub process_user : Private { + my ( $self, $c ) = @_; + + if ( $c->user_exists ) { + $c->stash->{alert_user} = $c->user->obj; + return; + } + + # Extract all the params to a hash to make them easier to work with + my %params = map { $_ => scalar $c->req->param($_) } + ( 'rznvy' ); # , 'password_register' ); + + # cleanup the email address + my $email = $params{rznvy} ? lc $params{rznvy} : ''; + $email =~ s{\s+}{}g; + + push @{ $c->stash->{errors} }, _('Please enter a valid email address') + unless is_valid_email( $email ); + + my $alert_user = $c->model('DB::User')->find_or_new( { email => $email } ); + $c->stash->{alert_user} = $alert_user; + +# # The user is trying to sign in. We only care about email from the params. +# if ( $c->req->param('submit_sign_in') ) { +# unless ( $c->forward( '/auth/sign_in', [ $email ] ) ) { +# $c->stash->{field_errors}->{password} = _('There was a problem with your email/password combination. Please try again.'); +# return 1; +# } +# my $user = $c->user->obj; +# $c->stash->{alert_user} = $user; +# return 1; +# } +# +# $alert_user->password( Utils::trim_text( $params{password_register} ) ); +} + +=head2 setup_coordinate_rss_feeds + +Takes the latitide and longitude from the stash and uses them to generate uris +for the local rss feeds + +=cut + +sub setup_coordinate_rss_feeds : Private { + my ( $self, $c ) = @_; + + $c->stash->{rss_feed_id} = + sprintf( 'local:%s:%s', $c->stash->{latitude}, $c->stash->{longitude} ); + + my $rss_feed; + if ( $c->stash->{pretty_pc_text} ) { + $rss_feed = $c->uri_for( "/rss/pc/" . $c->stash->{pretty_pc_text} ); + } + else { + $rss_feed = $c->uri_for( + sprintf( "/rss/l/%s,%s", + $c->stash->{latitude}, + $c->stash->{longitude} ) + ); + } + + $c->stash->{rss_feed_uri} = $rss_feed; + + $c->stash->{rss_feed_2k} = $rss_feed . '/2'; + $c->stash->{rss_feed_5k} = $rss_feed . '/5'; + $c->stash->{rss_feed_10k} = $rss_feed . '/10'; + $c->stash->{rss_feed_20k} = $rss_feed . '/20'; + + return 1; +} + +=head2 setup_council_rss_feeds + +Generate the details required to display the council/ward/area RSS feeds + +=cut + +sub setup_council_rss_feeds : Private { + my ( $self, $c ) = @_; + + $c->stash->{council_check_action} = 'alert'; + unless ( $c->forward('/council/load_and_check_councils_and_wards') ) { + $c->go('index'); + } + + ( $c->stash->{options}, $c->stash->{reported_to_options} ) = + $c->cobrand->council_rss_alert_options( $c->stash->{all_councils}, $c ); + + return 1; +} + +=head2 determine_location + +Do all the things we need to do to work out where the alert is for +and to setup the location related things for later + +=cut + +sub determine_location : Private { + my ( $self, $c ) = @_; + + # Try to create a location for whatever we have + unless ( $c->forward('/location/determine_location_from_coords') + || $c->forward('/location/determine_location_from_pc') ) + { + + if ( $c->stash->{possible_location_matches} ) { + $c->stash->{choose_target_uri} = $c->uri_for('/alert/list'); + $c->detach('choose'); + } + + $c->go('index') if $c->stash->{location_error}; + } + + # truncate the lat,lon for nicer urls + ( $c->stash->{latitude}, $c->stash->{longitude} ) = + map { Utils::truncate_coordinate($_) } + ( $c->stash->{latitude}, $c->stash->{longitude} ); + + my $dist = + mySociety::Gaze::get_radius_containing_population( $c->stash->{latitude}, + $c->stash->{longitude}, 200000 ); + $dist = int( $dist * 10 + 0.5 ); + $dist = $dist / 10.0; + $c->stash->{population_radius} = $dist; + + return 1; +} + +=head2 add_recent_photos + + $c->forward( 'add_recent_photos', [ $num_photos ] ); + +Adds the most recent $num_photos to the template. If there is coordinate +and population radius information in the stash uses that to limit it. + +=cut + +sub add_recent_photos : Private { + my ( $self, $c, $num_photos ) = @_; + + if ( $c->stash->{latitude} + and $c->stash->{longitude} + and $c->stash->{population_radius} ) + { + + $c->stash->{photos} = $c->cobrand->recent_photos( + $num_photos, + $c->stash->{latitude}, + $c->stash->{longitude}, + $c->stash->{population_radius} + ); + } + else { + $c->stash->{photos} = $c->cobrand->recent_photos($num_photos); + } + + return 1; +} + +sub choose : Private { + my ( $self, $c ) = @_; + $c->stash->{template} = 'alert/choose.html'; +} + + +=head2 setup_request + +Setup the variables we need for the rest of the request + +=cut + +sub setup_request : Private { + my ( $self, $c ) = @_; + + $c->stash->{rznvy} = $c->req->param('rznvy'); + $c->stash->{selected_feed} = $c->req->param('feed'); + + if ( $c->user ) { + $c->stash->{rznvy} ||= $c->user->email; + } + + $c->stash->{cobrand_form_elements} = $c->cobrand->form_elements('alerts'); + + return 1; +} + +=head1 AUTHOR + +Struan Donald + +=head1 LICENSE + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Around.pm b/perllib/FixMyStreet/App/Controller/Around.pm new file mode 100644 index 000000000..fcf91123e --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Around.pm @@ -0,0 +1,285 @@ +package FixMyStreet::App::Controller::Around; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use FixMyStreet::Map; +use List::MoreUtils qw(any); +use Encode; +use FixMyStreet::Map; +use Utils; + +=head1 NAME + +FixMyStreet::App::Controller::Around - Catalyst Controller + +=head1 DESCRIPTION + +Allow the user to search for reports around a particular location. + +=head1 METHODS + +=head2 around + +Find the location search and display nearby reports (for pc or lat,lon). + +For x,y searches convert to lat,lon and 301 redirect to them. + +If no search redirect back to the homepage. + +=cut + +sub around_index : Path : Args(0) { + my ( $self, $c ) = @_; + + # handle old coord systems + $c->forward('redirect_en_or_xy_to_latlon'); + + # Check if we have a partial report + my $partial_report = $c->forward('load_partial'); + + # Try to create a location for whatever we have + return + unless $c->forward('/location/determine_location_from_coords') + || $c->forward('/location/determine_location_from_pc'); + + # Check to see if the spot is covered by a council - if not show an error. + return unless $c->forward('check_location_is_acceptable'); + + # If we have a partial - redirect to /report/new so that it can be + # completed. + if ($partial_report) { + my $new_uri = $c->uri_for( + '/report/new', + { + partial => $c->stash->{partial_token}->token, + latitude => $c->stash->{latitude}, + longitude => $c->stash->{longitude}, + pc => $c->stash->{pc}, + } + ); + return $c->res->redirect($new_uri); + } + + # Show the nearby reports + $c->detach('display_location'); +} + +=head2 redirect_en_or_xy_to_latlon + + # detaches if there was a redirect + $c->forward('redirect_en_or_xy_to_latlon'); + +Handle coord systems that are no longer in use. + +=cut + +sub redirect_en_or_xy_to_latlon : Private { + my ( $self, $c ) = @_; + my $req = $c->req; + + # check for x,y or e,n requests + my $x = $req->param('x'); + my $y = $req->param('y'); + my $e = $req->param('e'); + my $n = $req->param('n'); + + # lat and lon - fill in below if we need to + my ( $lat, $lon ); + + if ( $x || $y ) { + ( $lat, $lon ) = FixMyStreet::Map::tile_xy_to_wgs84( $x, $y ); + ( $lat, $lon ) = map { Utils::truncate_coordinate($_) } ( $lat, $lon ); + } + elsif ( $e || $n ) { + ( $lat, $lon ) = Utils::convert_en_to_latlon_truncated( $e, $n ); + } + else { + return; + } + + # create a uri and redirect to it + my $ll_uri = $c->uri_for( '/around', { lat => $lat, lon => $lon } ); + $c->res->redirect( $ll_uri, 301 ); + $c->detach; +} + +=head2 load_partial + + my $partial_report = $c->forward('load_partial'); + +Check for the partial token and load the partial report. If found save it and +token to stash and return report. Otherwise return false. + +=cut + +sub load_partial : Private { + my ( $self, $c ) = @_; + + my $partial = scalar $c->req->param('partial') + || return; + + # is it in the database + my $token = + $c->model("DB::Token") + ->find( { scope => 'partial', token => $partial } ) # + || last; + + # can we get an id from it? + my $report_id = $token->data # + || last; + + # load the related problem + my $report = $c->cobrand->problems # + ->search( { id => $report_id, state => 'partial' } ) # + ->first + || last; + + # save what we found on the stash. + $c->stash->{partial_token} = $token; + $c->stash->{partial_report} = $report; + + return $report; +} + +=head2 display_location + +Display a specific lat/lng location (which may have come from a pc search). + +=cut + +sub display_location : Private { + my ( $self, $c ) = @_; + + # set the template to use + $c->stash->{template} = 'around/display_location.html'; + + # get the lat,lng + my $latitude = $c->stash->{latitude}; + my $longitude = $c->stash->{longitude}; + + # truncate the lat,lon for nicer rss urls, and strings for outputting + my $short_latitude = Utils::truncate_coordinate($latitude); + my $short_longitude = Utils::truncate_coordinate($longitude); + $c->stash->{short_latitude} = $short_latitude; + $c->stash->{short_longitude} = $short_longitude; + + # Deal with pin hiding/age + my $all_pins = $c->req->param('all_pins') ? 1 : undef; + $c->stash->{all_pins} = $all_pins; + my $interval = $all_pins ? undef : $c->cobrand->on_map_default_max_pin_age; + + # get the map features + my ( $on_map_all, $on_map, $around_map, $distance ) = + FixMyStreet::Map::map_features( $c, $latitude, $longitude, + $interval ); + + # copy the found reports to the stash + $c->stash->{on_map} = $on_map; + $c->stash->{around_map} = $around_map; + $c->stash->{distance} = $distance; + + # create a list of all the pins + my @pins; + unless ($c->req->param('no_pins')) { + @pins = map { + # Here we might have a DB::Problem or a DB::Nearby, we always want the problem. + my $p = (ref $_ eq 'FixMyStreet::App::Model::DB::Nearby') ? $_->problem : $_; + { + latitude => $p->latitude, + longitude => $p->longitude, + colour => $p->state eq 'fixed' ? 'green' : 'red', + id => $p->id, + title => $p->title, + } + } @$on_map_all, @$around_map; + } + + $c->stash->{page} = 'around'; # So the map knows to make clickable pins, update on pan + FixMyStreet::Map::display_map( + $c, + latitude => $latitude, + longitude => $longitude, + clickable => 1, + pins => \@pins, + ); + + return 1; +} + +=head2 check_location_is_acceptable + +Find the lat and lon in stash and check that they are acceptable to the council, +and that they are in UK (if we are in UK). + +=cut + +sub check_location_is_acceptable : Private { + my ( $self, $c ) = @_; + + # check that there are councils that can accept this location + $c->stash->{council_check_action} = 'submit_problem'; + $c->stash->{remove_redundant_councils} = 1; + return $c->forward('/council/load_and_check_councils'); +} + +=head2 /ajax + +Handle the ajax calls that the map makes when it is dragged. The info returned +is used to update the pins on the map and the text descriptions on the side of +the map. + +=cut + +sub ajax : Path('/ajax') { + my ( $self, $c ) = @_; + + # how far back should we go? + my $all_pins = $c->req->param('all_pins') ? 1 : undef; + my $interval = $all_pins ? undef : $c->cobrand->on_map_default_max_pin_age; + + # Need to be the class that can handle it + if ($c->req->param('bbox')) { + FixMyStreet::Map::set_map_class( 'OSM' ); + } + + # extract the data from the map + my ( $pins, $on_map, $around_map, $dist ) = + FixMyStreet::Map::map_pins( $c, $interval ); + + # render templates to get the html + my $on_map_list_html = + $c->view('Web') + ->render( $c, 'around/on_map_list_items.html', { on_map => $on_map } ); + + my $around_map_list_html = $c->view('Web')->render( + $c, + 'around/around_map_list_items.html', + { around_map => $around_map, dist => $dist } + ); + + # JSON encode the response + my $body = JSON->new->utf8(1)->pretty(1)->encode( + { + pins => $pins, + current => $on_map_list_html, + current_near => $around_map_list_html, + } + ); + + # assume this is not cacheable - may need to be more fine-grained later + $c->res->content_type('text/javascript; charset=utf-8'); + $c->res->header( 'Cache_Control' => 'max-age=0' ); + + if ( $c->req->param('bbox') ) { + $c->res->body($body); + } else { + # The JS needs the surrounding brackets for Tilma + $c->res->body("($body)"); + } +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Auth.pm b/perllib/FixMyStreet/App/Controller/Auth.pm new file mode 100644 index 000000000..c67de692a --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Auth.pm @@ -0,0 +1,283 @@ +package FixMyStreet::App::Controller::Auth; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use Email::Valid; +use Net::Domain::TLD; +use mySociety::AuthToken; + +=head1 NAME + +FixMyStreet::App::Controller::Auth - Catalyst Controller + +=head1 DESCRIPTION + +Controller for all the authentication related pages - create account, sign in, +sign out. + +=head1 METHODS + +=head2 index + +Present the user with a sign in / create account page. + +=cut + +sub general : Path : Args(0) { + my ( $self, $c ) = @_; + my $req = $c->req; + + $c->detach( 'redirect_on_signin', [ $req->param('r') ] ) + if $c->user && $req->param('r'); + + # all done unless we have a form posted to us + return unless $req->method eq 'POST'; + + # decide which action to take + $c->detach('email_sign_in') if $req->param('email_sign_in') + || $c->req->param('name') || $c->req->param('password_register'); + + $c->forward( 'sign_in' ) + && $c->detach( 'redirect_on_signin', [ $req->param('r') ] ); + +} + +=head2 sign_in + +Allow the user to sign in with a username and a password. + +=cut + +sub sign_in : Private { + my ( $self, $c, $email ) = @_; + + $email ||= $c->req->param('email') || ''; + my $password = $c->req->param('password_sign_in') || ''; + my $remember_me = $c->req->param('remember_me') || 0; + + # Sign out just in case + $c->logout(); + + if ( $email + && $password + && $c->authenticate( { email => $email, password => $password } ) ) + { + + # unless user asked to be remembered limit the session to browser + $c->set_session_cookie_expire(0) + unless $remember_me; + + return 1; + } + + $c->stash( + sign_in_error => 1, + email => $email, + remember_me => $remember_me, + ); + return; +} + +=head2 email_sign_in + +Email the user the details they need to sign in. Don't check for an account - if +there isn't one we can create it when they come back with a token (which +contains the email addresss). + +=cut + +sub email_sign_in : Private { + my ( $self, $c ) = @_; + + # check that the email is valid - otherwise flag an error + my $raw_email = lc( $c->req->param('email') || '' ); + + my $email_checker = Email::Valid->new( + -mxcheck => 1, + -tldcheck => 1, + -fqdn => 1, + ); + + my $good_email = $email_checker->address($raw_email); + if ( !$good_email ) { + $c->stash->{email} = $raw_email; + $c->stash->{email_error} = + $raw_email ? $email_checker->details : 'missing'; + return; + } + + my $user_params = {}; + $user_params->{password} = $c->req->param('password_register') + if $c->req->param('password_register'); + my $user = $c->model('DB::User')->new( $user_params ); + + my $token_obj = $c->model('DB::Token') # + ->create( + { + scope => 'email_sign_in', + data => { + email => $good_email, + r => $c->req->param('r'), + name => $c->req->param('name'), + password => $user->password, + } + } + ); + + $c->stash->{token} = $token_obj->token; + $c->send_email( 'login.txt', { to => $good_email } ); + $c->stash->{template} = 'auth/token.html'; +} + +=head2 token + +Handle the 'email_sign_in' tokens. Find the account for the email address +(creating if needed), authenticate the user and delete the token. + +=cut + +sub token : Path('/M') : Args(1) { + my ( $self, $c, $url_token ) = @_; + + # retrieve the token or return + my $token_obj = $url_token + ? $c->model('DB::Token')->find( { + scope => 'email_sign_in', token => $url_token + } ) + : undef; + + if ( !$token_obj ) { + $c->stash->{token_not_found} = 1; + return; + } + + # Sign out in case we are another user + $c->logout(); + + # get the email and scrap the token + my $data = $token_obj->data; + $token_obj->delete; + + # find or create the user related to the token. + my $user = $c->model('DB::User')->find_or_create( { email => $data->{email} } ); + $user->name( $data->{name} ) if $data->{name}; + $user->password( $data->{password}, 1 ) if $data->{password}; + $user->update; + $c->authenticate( { email => $user->email }, 'no_password' ); + + # send the user to their page + $c->detach( 'redirect_on_signin', [ $data->{r} ] ); +} + +=head2 redirect_on_signin + +Used after signing in to take the person back to where they were. + +=cut + + +sub redirect_on_signin : Private { + my ( $self, $c, $redirect ) = @_; + $redirect = 'my' unless $redirect; + $c->res->redirect( $c->uri_for( "/$redirect" ) ); +} + +=head2 redirect + +Used when trying to view a page that requires sign in when you're not. + +=cut + +sub redirect : Private { + my ( $self, $c ) = @_; + + my $uri = $c->uri_for( '/auth', { r => $c->req->path } ); + $c->res->redirect( $uri ); + $c->detach; + +} + +=head2 change_password + +Let the user change their password. + +=cut + +sub change_password : Local { + my ( $self, $c ) = @_; + + $c->detach( 'redirect' ) unless $c->user; + + # FIXME - CSRF check here + # FIXME - minimum criteria for passwords (length, contain number, etc) + + # If not a post then no submission + return unless $c->req->method eq 'POST'; + + # get the passwords + my $new = $c->req->param('new_password') // ''; + my $confirm = $c->req->param('confirm') // ''; + + # check for errors + my $password_error = + !$new && !$confirm ? 'missing' + : $new ne $confirm ? 'mismatch' + : ''; + + if ($password_error) { + $c->stash->{password_error} = $password_error; + $c->stash->{new_password} = $new; + $c->stash->{confirm} = $confirm; + return; + } + + # we should have a usable password - save it to the user + $c->user->obj->update( { password => $new } ); + $c->stash->{password_changed} = 1; + +} + +=head2 sign_out + +Log the user out. Tell them we've done so. + +=cut + +sub sign_out : Local { + my ( $self, $c ) = @_; + $c->logout(); +} + +=head2 check_auth + +Utility page - returns a simple message 'OK' and a 200 response if the user is +authenticated and a 'Unauthorized' / 401 reponse if they are not. + +Mainly intended for testing but might also be useful for ajax calls. + +=cut + +sub check_auth : Local { + my ( $self, $c ) = @_; + + # choose the response + my ( $body, $code ) # + = $c->user + ? ( 'OK', 200 ) + : ( 'Unauthorized', 401 ); + + # set the response + $c->res->body($body); + $c->res->code($code); + + # NOTE - really a 401 response should also contain a 'WWW-Authenticate' + # header but we ignore that here. The spec is not keeping up with usage. + + return; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Contact.pm b/perllib/FixMyStreet/App/Controller/Contact.pm new file mode 100644 index 000000000..88ac4987f --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Contact.pm @@ -0,0 +1,237 @@ +package FixMyStreet::App::Controller::Contact; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::Contact - Catalyst Controller + +=head1 DESCRIPTION + +Contact us page + +=head1 METHODS + +=cut + +=head2 index + +Display contact us page + +=cut + +sub index : Path : Args(0) { + my ( $self, $c ) = @_; + + return + unless $c->forward('setup_request') + && $c->forward('determine_contact_type'); +} + +=head2 submit + +Handle contact us form submission + +=cut + +sub submit : Path('submit') : Args(0) { + my ( $self, $c ) = @_; + + return + unless $c->forward('setup_request') + && $c->forward('determine_contact_type') + && $c->forward('validate') + && $c->forward('prepare_params_for_email') + && $c->forward('send_email'); +} + +=head2 determine_contact_type + +Work out if we have got here via a report/update or this is a +generic contact request and set up things accordingly + +=cut + +sub determine_contact_type : Private { + my ( $self, $c ) = @_; + + my $id = $c->req->param('id'); + my $update_id = $c->req->param('update_id'); + $id = undef unless $id && $id =~ /^[1-9]\d*$/; + $update_id = undef unless $update_id && $update_id =~ /^[1-9]\d*$/; + + if ($id) { + + $c->forward( '/report/load_problem_or_display_error', [ $id ] ); + + if ($update_id) { + my $update = $c->model('DB::Comment')->find( + { id => $update_id } + ); + + $c->stash->{update} = $update; + } + } + + return 1; +} + +=head2 validate + +Validate the form submission parameters. Sets error messages and redirect +to index page if errors. + +=cut + +sub validate : Private { + my ( $self, $c ) = @_; + + my ( %field_errors, @errors ); + my %required = ( + name => _('Please enter your name'), + em => _('Please enter your email'), + subject => _('Please enter a subject'), + message => _('Please write a message') + ); + + foreach my $field ( keys %required ) { + $field_errors{$field} = $required{$field} + unless $c->req->param($field) =~ /\S/; + } + + unless ( $field_errors{em} ) { + $field_errors{em} = _('Please enter a valid email address') + if !mySociety::EmailUtil::is_valid_email( $c->req->param('em') ); + } + + push @errors, _('Illegal ID') + if $c->req->param('id') && $c->req->param('id') !~ /^[1-9]\d*$/ + or $c->req->param('update_id') + && $c->req->param('update_id') !~ /^[1-9]\d*$/; + + unshift @errors, + _('There were problems with your report. Please see below.') + if scalar keys %field_errors; + + if ( @errors or scalar keys %field_errors ) { + $c->stash->{errors} = \@errors; + $c->stash->{field_errors} = \%field_errors; + $c->go('index'); + } + + return 1; +} + +=head2 prepare_params_for_email + +Does neccessary reformating of exiting params and add any additional +information required for emailing ( problem ids, admin page links etc ) + +=cut + +sub prepare_params_for_email : Private { + my ( $self, $c ) = @_; + + $c->stash->{message} =~ s/\r\n/\n/g; + $c->stash->{subject} =~ s/\r|\n/ /g; + + my $base_url = $c->cobrand->base_url_for_emails( $c->cobrand->extra_data ); + my $admin_base_url = $c->cobrand->admin_base_url + || 'https://secure.mysociety.org/admin/bci/'; + + if ( $c->stash->{update} ) { + + my $problem_url = $base_url . '/report/' . $c->stash->{update}->problem_id + . '#update_' . $c->stash->{update}->id; + my $admin_url = $admin_base_url . 'update_edit/' . $c->stash->{update}->id; + $c->stash->{message} .= sprintf( + " \n\n[ Complaint about update %d on report %d - %s - %s ]", + $c->stash->{update}->id, + $c->stash->{update}->problem_id, + $problem_url, $admin_url + ); + } + elsif ( $c->stash->{problem} ) { + + my $problem_url = $base_url . '/report/' . $c->stash->{problem}->id; + my $admin_url = $admin_base_url . 'report_edit/' . $c->stash->{problem}->id; + $c->stash->{message} .= sprintf( + " \n\n[ Complaint about report %d - %s - %s ]", + $c->stash->{problem}->id, + $problem_url, $admin_url + ); + } + + return 1; +} + +=head2 setup_request + +Pulls things from request into stash and adds other information +generally required to stash + +=cut + +sub setup_request : Private { + my ( $self, $c ) = @_; + + $c->stash->{contact_email} = $c->cobrand->contact_email; + $c->stash->{contact_email} =~ s/\@/@/; + + for my $param (qw/em subject message/) { + $c->stash->{$param} = $c->req->param($param); + } + + # name is already used in the stash for the app class name + $c->stash->{form_name} = $c->req->param('name'); + + return 1; +} + +=head2 send_email + +Sends the email + +=cut + +sub send_email : Private { + my ( $self, $c ) = @_; + + my $recipient = $c->cobrand->contact_email(); + my $recipient_name = $c->cobrand->contact_name(); + + $c->stash->{host} = $c->req->header('HOST'); + $c->stash->{ip} = $c->req->address; + $c->stash->{ip} .= + $c->req->header('X-Forwarded-For') + ? ' ( forwarded from ' . $c->req->header('X-Forwarded-For') . ' )' + : ''; + + $c->send_email( 'contact.txt', { + to => [ [ $recipient, _($recipient_name) ] ], + from => [ $c->stash->{em}, $c->stash->{form_name} ], + subject => 'FMS message: ' . $c->stash->{subject}, + }); + + # above is always succesful :( + $c->stash->{success} = 1; + + return 1; +} + +=head1 AUTHOR + +Struan Donald + +=head1 LICENSE + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Council.pm b/perllib/FixMyStreet/App/Controller/Council.pm new file mode 100644 index 000000000..35e3d0d11 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Council.pm @@ -0,0 +1,107 @@ +package FixMyStreet::App::Controller::Council; +use Moose; +use namespace::autoclean; + +BEGIN {extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::Council - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=head2 load_and_check_councils_and_wards + +Try to load councils and wards for this location and check that we have at least one. If +there are no councils then return false. + +=cut + +sub load_and_check_councils_and_wards : Private { + my ( $self, $c ) = @_; + my @area_types = ( $c->cobrand->area_types(), @$mySociety::VotingArea::council_child_types ); + $c->stash->{area_types} = \@area_types; + $c->forward('load_and_check_councils'); +} + +=head2 load_and_check_councils + +Try to load councils for this location and check that we have at least one. If +there are no councils then return false. + +=cut + +sub load_and_check_councils : Private { + my ( $self, $c ) = @_; + my $latitude = $c->stash->{latitude}; + my $longitude = $c->stash->{longitude}; + + # Look up councils and do checks for the point we've got + my @area_types; + if ( $c->stash->{area_types} and scalar @{ $c->stash->{area_types} } ) { + @area_types = @{ $c->stash->{area_types} }; + } else { + @area_types = $c->cobrand->area_types(); + } + + # TODO: I think we want in_gb_locale around the MaPit line, needs testing + my $all_councils; + if ( $c->stash->{fetch_all_areas} ) { + my %area_types = map { $_ => 1 } @area_types; + my $all_areas = + mySociety::MaPit::call( 'point', "4326/$longitude,$latitude" ); + $c->stash->{all_areas} = $all_areas; + $all_councils = { + map { $_ => $all_areas->{$_} } + grep { $area_types{ $all_areas->{$_}->{type} } } + keys %$all_areas + }; + } else { + $all_councils = + mySociety::MaPit::call( 'point', "4326/$longitude,$latitude", + type => \@area_types ); + } + + # Let cobrand do a check + my ( $success, $error_msg ) = + $c->cobrand->council_check( { all_councils => $all_councils }, + $c->stash->{council_check_action} ); + if ( !$success ) { + $c->stash->{location_error} = $error_msg; + return; + } + + # edit hash in-place + $c->cobrand->remove_redundant_councils($all_councils) if $c->stash->{remove_redundant_councils}; + + # If we don't have any councils we can't accept the report + if ( !scalar keys %$all_councils ) { + $c->stash->{location_offshore} = 1; + return; + } + + # all good if we have some councils left + $c->stash->{all_councils} = $all_councils; + $c->stash->{all_council_names} = + [ map { $_->{name} } values %$all_councils ]; + return 1; +} + +=head1 AUTHOR + +Struan Donald + +=head1 LICENSE + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/JSON.pm b/perllib/FixMyStreet/App/Controller/JSON.pm new file mode 100644 index 000000000..a89fb3e6c --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/JSON.pm @@ -0,0 +1,141 @@ +package FixMyStreet::App::Controller::JSON; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use JSON; +use DateTime; +use DateTime::Format::ISO8601; +use List::MoreUtils 'uniq'; + +=head1 NAME + +FixMyStreet::App::Controller::JSON - Catalyst Controller + +=head1 DESCRIPTION + +Provide information as JSON + +=head1 METHODS + +=head2 problems + +Provide JSON of new/fixed problems in a specified time range + +=cut + +sub problems : Local { + my ( $self, $c, $path_type ) = @_; + + # get the type from the path - this is to deal with the historic url + # structure. In futur + $path_type ||= ''; + my $type = + $path_type eq 'new' ? 'new_problems' + : $path_type eq 'fixed' ? 'fixed_problems' + : ''; + + # gather the parameters + my $start_date = $c->req->param('start_date') || ''; + my $end_date = $c->req->param('end_date') || ''; + my $category = $c->req->param('category') || ''; + + my $yyyy_mm_dd = qr{^\d{4}-\d\d-\d\d$}; + if ( $start_date !~ $yyyy_mm_dd + || $end_date !~ $yyyy_mm_dd ) + { + $c->stash->{error} = 'Invalid dates supplied'; + return; + } + + # convert the dates to datetimes and trap errors + my $iso8601 = DateTime::Format::ISO8601->new; + my $start_dt = eval { $iso8601->parse_datetime($start_date); }; + my $end_dt = eval { $iso8601->parse_datetime($end_date); }; + unless ( $start_dt && $end_dt ) { + $c->stash->{error} = 'Invalid dates supplied'; + return; + } + + # check that the dates are sane + if ( $start_dt > $end_dt ) { + $c->stash->{error} = 'Start date after end date'; + return; + } + + # check that the type is supported + unless ( $type eq 'new_problems' || $type eq 'fixed_problems' ) { + $c->stash->{error} = 'Invalid type supplied'; + return; + } + + # query the database + my ( $state, $date_col ); + if ( $type eq 'new_problems' ) { + $state = 'confirmed'; + $date_col = 'confirmed'; + } elsif ( $type eq 'fixed_problems' ) { + $state = 'fixed'; + $date_col = 'lastupdate'; + } + + my $one_day = DateTime::Duration->new( days => 1 ); + my $query = { + $date_col => { + '>=' => $start_dt, + '<=' => $end_dt + $one_day, + }, + state => $state, + }; + $query->{category} = $category if $category; + my @problems = $c->cobrand->problems->search( $query, { + order_by => { -asc => 'confirmed' }, + columns => [ + 'id', 'title', 'council', 'category', + 'detail', 'name', 'anonymous', 'confirmed', + 'whensent', 'service', + 'latitude', 'longitude', 'used_map', + 'state', 'lastupdate', + ] + } ); + + my @councils; + foreach my $problem (@problems) { + $problem->name( '' ) if $problem->anonymous == 1; + $problem->service( 'Web interface' ) if $problem->service eq ''; + if ($problem->council) { + (my $council = $problem->council) =~ s/\|.*//g; + my @council_ids = split /,/, $council; + push(@councils, @council_ids); + $problem->council( \@council_ids ); + } + } + @councils = uniq @councils; + my $areas_info = mySociety::MaPit::call('areas', \@councils); + foreach my $problem (@problems) { + if ($problem->council) { + my @council_names = map { $areas_info->{$_}->{name} } @{$problem->council} ; + $problem->council( join(' and ', @council_names) ); + } + } + + @problems = map { { $_->get_columns } } @problems; + $c->stash->{response} = \@problems; +} + +sub end : Private { + my ( $self, $c ) = @_; + + my $response = + $c->stash->{error} + ? { error => $c->stash->{error} } + : $c->stash->{response}; + + $c->res->content_type('application/json; charset=utf-8'); + $c->res->body( encode_json( $response || {} ) ); +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Location.pm b/perllib/FixMyStreet/App/Controller/Location.pm new file mode 100644 index 000000000..9f8260768 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Location.pm @@ -0,0 +1,130 @@ +package FixMyStreet::App::Controller::Location; +use Moose; +use namespace::autoclean; + +BEGIN {extends 'Catalyst::Controller'; } + +use Encode; + +=head1 NAME + +FixMyStreet::App::Controller::Location - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +This is purely an internal controller for keeping all the location finding things in one place + +=head1 METHODS + +=head2 determine_location_from_coords + +Use latitude and longitude if provided in parameters. + +=cut + +sub determine_location_from_coords : Private { + my ( $self, $c ) = @_; + + my $latitude = $c->req->param('latitude') || $c->req->param('lat'); + my $longitude = $c->req->param('longitude') || $c->req->param('lon'); + + if ( defined $latitude && defined $longitude ) { + $c->stash->{latitude} = $latitude; + $c->stash->{longitude} = $longitude; + + # Also save the pc if there is one + if ( my $pc = $c->req->param('pc') ) { + $c->stash->{pc} = $pc; + } + + return $c->forward( 'check_location' ); + } + + return; +} + +=head2 determine_location_from_pc + +User has searched for a location - try to find it for them. + +If one match is found returns true and lat/lng is set. + +If several possible matches are found puts an array onto stash so that user can be prompted to pick one and returns false. + +If no matches are found returns false. + +=cut + +sub determine_location_from_pc : Private { + my ( $self, $c, $pc ) = @_; + + # check for something to search + $pc ||= $c->req->param('pc') || return; + $c->stash->{pc} = $pc; # for template + + my ( $latitude, $longitude, $error ) = + FixMyStreet::Geocode::lookup( $pc, $c ); + + # If we got a lat/lng set to stash and return true + if ( defined $latitude && defined $longitude ) { + $c->stash->{latitude} = $latitude; + $c->stash->{longitude} = $longitude; + return $c->forward( 'check_location' ); + } + + # $error doubles up to return multiple choices by being an array + if ( ref($error) eq 'ARRAY' ) { + @$error = map { + decode_utf8($_); + s/, United Kingdom//; + s/, UK//; + $_; + } @$error; + $c->stash->{possible_location_matches} = $error; + return; + } + + # pass errors back to the template + $c->stash->{location_error} = $error; + return; +} + +=head2 check_location + +Just make sure that for UK installs, our co-ordinates are indeed in the UK. + +=cut + +sub check_location : Private { + my ( $self, $c ) = @_; + + if ( $c->stash->{latitude} && $c->cobrand->country eq 'GB' ) { + eval { Utils::convert_latlon_to_en( $c->stash->{latitude}, $c->stash->{longitude} ); }; + if (my $error = $@) { + mySociety::Locale::pop(); # We threw exception, so it won't have happened. + $error = _('That location does not appear to be in Britain; please try again.') + if $error =~ /of the area covered/; + $c->stash->{location_error} = $error; + return; + } + } + + return 1; +} + +=head1 AUTHOR + +Struan Donald + +=head1 LICENSE + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/My.pm b/perllib/FixMyStreet/App/Controller/My.pm new file mode 100644 index 000000000..19b3ffee0 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/My.pm @@ -0,0 +1,69 @@ +package FixMyStreet::App::Controller::My; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::My - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + +=head2 index + +=cut + +sub my : Path : Args(0) { + my ( $self, $c ) = @_; + + $c->detach( '/auth/redirect' ) unless $c->user; + + my $p_page = $c->req->params->{p} || 1; + my $u_page = $c->req->params->{u} || 1; + + my $pins = []; + my $problems = {}; + my $rs = $c->user->problems->search( undef, + { rows => 50 } )->page( $p_page ); + + while ( my $problem = $rs->next ) { + push @$pins, { + latitude => $problem->latitude, + longitude => $problem->longitude, + colour => $problem->state eq 'fixed' ? 'green' : 'red', + id => $problem->id, + title => $problem->title, + }; + push @{ $problems->{$problem->state} }, $problem; + } + $c->stash->{problems_pager} = $rs->pager; + $c->stash->{problems} = $problems; + + $rs = $c->user->comments->search( + { state => 'confirmed' }, + { rows => 50 } )->page( $u_page ); + my @updates = $rs->all; + $c->stash->{updates} = \@updates; + $c->stash->{updates_pager} = $rs->pager; + + $c->stash->{page} = 'my'; + FixMyStreet::Map::display_map( + $c, + latitude => $pins->[0]{latitude}, + longitude => $pins->[0]{longitude}, + pins => $pins, + any_zoom => 1, + ) + if @$pins; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Photo.pm b/perllib/FixMyStreet/App/Controller/Photo.pm new file mode 100644 index 000000000..17862aa0a --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Photo.pm @@ -0,0 +1,103 @@ +package FixMyStreet::App::Controller::Photo; +use Moose; +use namespace::autoclean; + +BEGIN {extends 'Catalyst::Controller'; } + +use DateTime::Format::HTTP; + +=head1 NAME + +FixMyStreet::App::Controller::Photo - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + + +=head2 index + +Display a photo + +=cut + +sub index :Path :Args(0) { + my ( $self, $c ) = @_; + + my $id = $c->req->param('id'); + my $comment = $c->req->param('c'); + $c->detach( 'no_photo' ) unless $id || $comment; + + my @photo; + if ( $comment ) { + @photo = $c->model('DB::Comment')->search( { + id => $comment, + state => 'confirmed', + photo => { '!=', undef }, + } ); + } else { + # GoogleBot-Image is doing this for some reason? + if ( $id =~ m{ ^(\d+) \D .* $ }x ) { + return $c->res->redirect( $c->uri_with( { id => $1 } ), 301 ); + } + + $c->detach( 'no_photo' ) if $id =~ /\D/; + @photo = $c->cobrand->problems->search( { + id => $id, + state => [ 'confirmed', 'fixed', 'partial' ], + photo => { '!=', undef }, + } ); + } + + $c->detach( 'no_photo' ) unless @photo; + + my $photo = $photo[0]->photo; + if ( $c->req->param('tn' ) ) { + $photo = _resize( $photo, 'x100' ); + } elsif ( $c->cobrand->default_photo_resize ) { + $photo = _resize( $photo, $c->cobrand->default_photo_resize ); + } + + my $dt = DateTime->now(); + $dt->set_year( $dt->year + 1 ); + + $c->res->content_type( 'image/jpeg' ); + $c->res->header( 'expires', DateTime::Format::HTTP->format_datetime( $dt ) ); + $c->res->body( $photo ); +} + +sub no_photo : Private { + my ( $self, $c ) = @_; + $c->detach( '/page_error_404_not_found', [ 'No photo' ] ); +} + +sub _resize { + my ($photo, $size) = @_; + use Image::Magick; + my $image = Image::Magick->new; + $image->BlobToImage($photo); + my $err = $image->Scale(geometry => "$size>"); + throw Error::Simple("resize failed: $err") if "$err"; + my @blobs = $image->ImageToBlob(); + undef $image; + return $blobs[0]; +} + +=head1 AUTHOR + +Struan Donald + +=head1 LICENSE + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Questionnaire.pm b/perllib/FixMyStreet/App/Controller/Questionnaire.pm new file mode 100755 index 000000000..acb1628cf --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Questionnaire.pm @@ -0,0 +1,325 @@ +package FixMyStreet::App::Controller::Questionnaire; + +use Moose; +use namespace::autoclean; +use Path::Class; +use Utils; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::Questionnaire - Catalyst Controller + +=head1 DESCRIPTION + +Deals with report questionnaires. + +=head1 METHODS + +=cut + +=head2 check_questionnaire + +Checks the questionnaire still needs answering and is in the right state. Also +finds out if this user has answered the "ever reported" question before. + +=cut + +sub check_questionnaire : Private { + my ( $self, $c ) = @_; + + my $questionnaire = $c->stash->{questionnaire}; + + my $problem_id = $questionnaire->problem_id; + + if ( $questionnaire->whenanswered ) { + my $problem_url = $c->uri_for( "/report/$problem_id" ); + my $contact_url = $c->uri_for( "/contact" ); + $c->stash->{message} = sprintf(_("You have already answered this questionnaire. If you have a question, please <a href='%s'>get in touch</a>, or <a href='%s'>view your problem</a>.\n"), $contact_url, $problem_url); + $c->stash->{template} = 'errors/generic.html'; + $c->detach; + } + + unless ( $questionnaire->problem->state eq 'confirmed' || $questionnaire->problem->state eq 'fixed' ) { + $c->detach('missing_problem'); + } + + $c->stash->{problem} = $questionnaire->problem; + $c->stash->{answered_ever_reported} = $questionnaire->problem->user->answered_ever_reported; + + # EHA needs to know how many to alter display, and whether to send another or not + if ($c->cobrand->moniker eq 'emptyhomes') { + $c->stash->{num_questionnaire} = $c->model('DB::Questionnaire')->count( + { problem_id => $c->stash->{problem}->id } + ); + } + +} + +=head2 submit + +If someone submits a questionnaire - either a full style one (when we'll have a +token), or the mini own-report one (when we'll have a problem ID). + +=cut + +sub submit : Path('submit') { + my ( $self, $c ) = @_; + + if ( $c->req->params->{token} ) { + $c->forward('submit_standard'); + } elsif ( $c->req->params->{problem} ) { + $c->forward('submit_creator_fixed'); + } else { + $c->detach( '/page_error_404_not_found' ); + } + + return 1; +} + +=head2 missing_problem + +Display couldn't locate problem error message + +=cut + +sub missing_problem : Private { + my ( $self, $c ) = @_; + + $c->stash->{message} = _("I'm afraid we couldn't locate your problem in the database.\n"); + $c->stash->{template} = 'errors/generic.html'; +} + +sub submit_creator_fixed : Private { + my ( $self, $c ) = @_; + + my @errors; + + map { $c->stash->{$_} = $c->req->params->{$_} || '' } qw(reported problem); + + # should only be able to get to here if we are logged and we have a + # problem + unless ( $c->user && $c->stash->{problem} ) { + $c->detach('missing_problem'); + } + + my $problem = $c->cobrand->problems->find( { id => $c->stash->{problem} } ); + + # you should not be able to answer questionnaires about problems + # that you've not submitted + if ( $c->user->id != $problem->user->id ) { + $c->detach('missing_problem'); + } + + push @errors, _('Please say whether you\'ve ever reported a problem to your council before') unless $c->stash->{reported}; + + $c->stash->{problem_id} = $c->stash->{problem}; + $c->stash->{errors} = \@errors; + $c->detach( 'creator_fixed' ) if scalar @errors; + + my $questionnaire = $c->model( 'DB::Questionnaire' )->find_or_new( + { + problem_id => $c->stash->{problem}, + old_state => 'confirmed', + new_state => 'fixed', + } + ); + + unless ( $questionnaire->in_storage ) { + $questionnaire->ever_reported( $c->stash->{reported} eq 'Yes' ? 1 : 0 ); + $questionnaire->whensent( \'ms_current_timestamp()' ); + $questionnaire->whenanswered( \'ms_current_timestamp()' ); + $questionnaire->insert; + } + + $c->stash->{creator_fixed} = 1; + $c->stash->{template} = 'tokens/confirm_update.html'; + + return 1; +} + +sub submit_standard : Private { + my ( $self, $c ) = @_; + + $c->forward( '/tokens/load_questionnaire', [ $c->req->params->{token} ] ); + $c->forward( 'check_questionnaire' ); + $c->forward( 'process_questionnaire' ); + + my $problem = $c->stash->{problem}; + my $old_state = $problem->state; + my $new_state = ''; + $new_state = 'fixed' if $c->stash->{been_fixed} eq 'Yes' && $old_state eq 'confirmed'; + $new_state = 'confirmed' if $c->stash->{been_fixed} eq 'No' && $old_state eq 'fixed'; + + # Record state change, if there was one + if ( $new_state ) { + $problem->state( $new_state ); + $problem->lastupdate( \'ms_current_timestamp()' ); + } + + # If it's not fixed and they say it's still not been fixed, record time update + if ( $c->stash->{been_fixed} eq 'No' && $old_state eq 'confirmed' ) { + $problem->lastupdate( \'ms_current_timestamp()' ); + } + + # Record questionnaire response + my $reported = undef; + $reported = 1 if $c->stash->{reported} eq 'Yes'; + $reported = 0 if $c->stash->{reported} eq 'No'; + + my $q = $c->stash->{questionnaire}; + $q->update( { + whenanswered => \'ms_current_timestamp()', + ever_reported => $reported, + old_state => $old_state, + new_state => $c->stash->{been_fixed} eq 'Unknown' ? 'unknown' : ($new_state || $old_state), + } ); + + # Record an update if they've given one, or if there's a state change + if ( $new_state || $c->stash->{update} ) { + my $update = $c->stash->{update} || _('Questionnaire filled in by problem reporter'); + $update = $c->model('DB::Comment')->new( + { + problem => $problem, + name => $problem->name, + user => $problem->user, + text => $update, + state => 'confirmed', + mark_fixed => $new_state eq 'fixed' ? 1 : 0, + mark_open => $new_state eq 'confirmed' ? 1 : 0, + lang => $c->stash->{lang_code}, + cobrand => $c->cobrand->moniker, + cobrand_data => $c->cobrand->extra_update_data, + confirmed => \'ms_current_timestamp()', + anonymous => $problem->anonymous, + } + ); + if ( my $fileid = $c->stash->{upload_fileid} ) { + my $file = file( $c->config->{UPLOAD_CACHE}, "$fileid.jpg" ); + my $blob = $file->slurp; + $file->remove; + $update->photo($blob); + } + $update->insert; + } + + # If they've said they want another questionnaire, mark as such + $problem->send_questionnaire( 1 ) + if ($c->stash->{been_fixed} eq 'No' || $c->stash->{been_fixed} eq 'Unknown') && $c->stash->{another} eq 'Yes'; + $problem->update; + + $c->stash->{new_state} = $new_state; + $c->stash->{template} = 'questionnaire/completed.html'; +} + +sub process_questionnaire : Private { + my ( $self, $c ) = @_; + + map { $c->stash->{$_} = $c->req->params->{$_} || '' } qw(been_fixed reported another update); + + # EHA questionnaires done for you + if ($c->cobrand->moniker eq 'emptyhomes') { + $c->stash->{another} = $c->stash->{num_questionnaire}==1 ? 'Yes' : 'No'; + } + + my @errors; + push @errors, _('Please state whether or not the problem has been fixed') + unless $c->stash->{been_fixed}; + + if ($c->cobrand->ask_ever_reported) { + push @errors, _('Please say whether you\'ve ever reported a problem to your council before') + unless $c->stash->{reported} || $c->stash->{answered_ever_reported}; + } + + push @errors, _('Please indicate whether you\'d like to receive another questionnaire') + if ($c->stash->{been_fixed} eq 'No' || $c->stash->{been_fixed} eq 'Unknown') && !$c->stash->{another}; + + push @errors, _('Please provide some explanation as to why you\'re reopening this report') + if $c->stash->{been_fixed} eq 'No' && $c->stash->{problem}->state eq 'fixed' && !$c->stash->{update}; + + $c->forward('/report/new/process_photo'); + push @errors, $c->stash->{photo_error} + if $c->stash->{photo_error}; + + push @errors, _('Please provide some text as well as a photo') + if $c->stash->{upload_fileid} && !$c->stash->{update}; + + if (@errors) { + $c->stash->{errors} = [ @errors ]; + $c->detach( 'display' ); + } +} + +# Sent here from email token action. Simply load and display questionnaire. +sub index : Private { + my ( $self, $c ) = @_; + $c->forward( 'check_questionnaire' ); + $c->forward( 'display' ); +} + +=head2 display + +Displays a questionnaire, either after bad submission or directly from email token. + +=cut + +sub display : Private { + my ( $self, $c ) = @_; + + $c->stash->{template} = 'questionnaire/index.html'; + + my $problem = $c->stash->{questionnaire}->problem; + + ( $c->stash->{short_latitude}, $c->stash->{short_longitude} ) = + map { Utils::truncate_coordinate($_) } + ( $problem->latitude, $problem->longitude ); + + $c->stash->{updates} = $c->model('DB::Comment')->search( + { problem_id => $problem->id, state => 'confirmed' }, + { order_by => 'confirmed' } + ); + + $c->stash->{page} = 'questionnaire'; + FixMyStreet::Map::display_map( + $c, + latitude => $problem->latitude, + longitude => $problem->longitude, + pins => [ { + latitude => $problem->latitude, + longitude => $problem->longitude, + colour => $problem->state eq 'fixed' ? 'green' : 'red', + } ], + ); +} + +=head2 creator_fixed + +Display the reduced questionnaire that we display when the reporter of a +problem submits an update marking it as fixed. + +=cut + +sub creator_fixed : Private { + my ( $self, $c ) = @_; + + $c->stash->{template} = 'questionnaire/creator_fixed.html'; + + return 1; +} + +=head1 AUTHOR + +Matthew Somerville + +=head1 LICENSE + +Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. +Licensed under the Affero GPL. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; + diff --git a/perllib/FixMyStreet/App/Controller/Report.pm b/perllib/FixMyStreet/App/Controller/Report.pm new file mode 100644 index 000000000..6596615c6 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Report.pm @@ -0,0 +1,144 @@ +package FixMyStreet::App::Controller::Report; + +use Moose; +use namespace::autoclean; +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::Report - display a report + +=head1 DESCRIPTION + +Show a report + +=head1 ACTIONS + +=head2 index + +Redirect to homepage unless C<id> parameter in query, in which case redirect to +'/report/$id'. + +=cut + +sub index : Path('') : Args(0) { + my ( $self, $c ) = @_; + + my $id = $c->req->param('id'); + + my $uri = + $id + ? $c->uri_for( '/report', $id ) + : $c->uri_for('/'); + + $c->res->redirect($uri); +} + +=head2 report_display + +Display a report. + +=cut + +sub display : Path('') : Args(1) { + my ( $self, $c, $id ) = @_; + + if ( + $id =~ m{ ^ 3D (\d+) $ }x # Some council with bad email software + || $id =~ m{ ^(\d+) \D .* $ }x # trailing garbage + ) + { + return $c->res->redirect( $c->uri_for($1), 301 ); + } + + $c->forward('load_problem_or_display_error', [ $id ] ); + $c->forward( 'load_updates' ); + $c->forward( 'format_problem_for_display' ); +} + +sub load_problem_or_display_error : Private { + my ( $self, $c, $id ) = @_; + + # try to load a report if the id is a number + my $problem + = ( !$id || $id =~ m{\D} ) # is id non-numeric? + ? undef # ...don't even search + : $c->cobrand->problems->find( { id => $id } ); + + # check that the problem is suitable to show. + if ( !$problem || $problem->state eq 'unconfirmed' || $problem->state eq 'partial' ) { + $c->detach( '/page_error_404_not_found', [ _('Unknown problem ID') ] ); + } + elsif ( $problem->state eq 'hidden' ) { + $c->detach( + '/page_error_410_gone', + [ _('That report has been removed from FixMyStreet.') ] # + ); + } + + $c->stash->{problem} = $problem; + return 1; +} + +sub load_updates : Private { + my ( $self, $c ) = @_; + + my $updates = $c->model('DB::Comment')->search( + { problem_id => $c->stash->{problem}->id, state => 'confirmed' }, + { order_by => 'confirmed' } + ); + + $c->stash->{updates} = $updates; + + return 1; +} + +sub format_problem_for_display : Private { + my ( $self, $c ) = @_; + + my $problem = $c->stash->{problem}; + + $c->stash->{banner} = $c->cobrand->generate_problem_banner($problem); + + $c->stash->{cobrand_alert_fields} = $c->cobrand->form_elements('/alerts'); + $c->stash->{cobrand_update_fields} = + $c->cobrand->form_elements('/updateForm'); + + ( $c->stash->{short_latitude}, $c->stash->{short_longitude} ) = + map { Utils::truncate_coordinate($_) } + ( $problem->latitude, $problem->longitude ); + + unless ( $c->req->param('submit_update') ) { + $c->stash->{add_alert} = 1; + } + + $c->forward('generate_map_tags'); + + return 1; +} + +sub generate_map_tags : Private { + my ( $self, $c ) = @_; + + my $problem = $c->stash->{problem}; + + $c->stash->{page} = 'report'; + FixMyStreet::Map::display_map( + $c, + latitude => $problem->latitude, + longitude => $problem->longitude, + pins => $problem->used_map + ? [ { + latitude => $problem->latitude, + longitude => $problem->longitude, + colour => 'blue', + } ] + : [], + ); + + return 1; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Report/New.pm b/perllib/FixMyStreet/App/Controller/Report/New.pm new file mode 100644 index 000000000..346dfb377 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Report/New.pm @@ -0,0 +1,1047 @@ +package FixMyStreet::App::Controller::Report::New; + +use Moose; +use namespace::autoclean; +BEGIN { extends 'Catalyst::Controller'; } + +use FixMyStreet::Geocode; +use Encode; +use Image::Magick; +use List::MoreUtils qw(uniq); +use POSIX 'strcoll'; +use HTML::Entities; +use mySociety::MaPit; +use Path::Class; +use Utils; +use mySociety::EmailUtil; +use mySociety::TempFiles; + +=head1 NAME + +FixMyStreet::App::Controller::Report::New + +=head1 DESCRIPTION + +Create a new report, or complete a partial one . + +=head1 PARAMETERS + +=head2 flow control + +submit_problem: true if a problem has been submitted, at all. +submit_sign_in: true if the sign in button has been clicked by logged out user. +submit_register: true if the register/confirm by email button has been clicked +by logged out user. + +=head2 location (required) + +We require a location - either lat/lng or a tile click. + +longitude, latitude: location of the report - either determined from the +address/postcode or from a map click. + +x, y, tile_xxx.yyy.x, tile_xxx.yyy.y: x and y are the tile locations. The +'tile_xxx.yyy' pair are the click locations on the tile. These can be converted +back into lat/lng by the map code. + +=head2 image related + +Parameters are 'photo' or 'upload_fileid'. The 'photo' is used when a user has selected a file. Once it has been uploaded it is cached on disk so that if there are errors on the form it need not be uploaded again. The cache location is stored in 'upload_fileid'. + +=head2 optional + +pc: location user searched for + +skipped: true if the map was skipped - may mean that the location is not as +accurate as we'd like. Default is false. + +upload_fileid: set if there is an uploaded file (might not be needed if we use the Catalyst upload handlers) + +may_show_name: bool - false if the user wants this report to be anonymous. + +title + +detail + +name + +email + +phone + +partial + +=cut + +sub report_new : Path : Args(0) { + my ( $self, $c ) = @_; + + # create the report - loading a partial if available + $c->forward('initialize_report'); + + # work out the location for this report and do some checks + return $c->forward('redirect_to_around') + unless $c->forward('determine_location'); + + # create a problem from the submitted details + $c->stash->{template} = "report/new/fill_in_details.html"; + $c->forward('setup_categories_and_councils'); + $c->forward('generate_map'); + + # deal with the user and report and check both are happy + return unless $c->forward('check_form_submitted'); + $c->forward('process_user'); + $c->forward('process_report'); + $c->forward('process_photo'); + return unless $c->forward('check_for_errors'); + $c->forward('save_user_and_report'); + $c->forward('redirect_or_confirm_creation'); +} + +=head2 report_import + +Action to accept report creations from iPhones and other mobile apps. URL is +'/import' to be compatible with existing apps. + +=cut + +sub report_import : Path('/import') { + my ( $self, $c ) = @_; + + # If this is not a POST then just print out instructions for using page + return unless $c->req->method eq 'POST'; + + # anything else we return is plain text + $c->res->content_type('text/plain; charset=utf-8'); + + my %input = + map { $_ => $c->req->param($_) || '' } ( + 'service', 'subject', 'detail', 'name', 'email', 'phone', + 'easting', 'northing', 'lat', 'lon', 'id', 'phone_id', + ); + + my @errors; + + # Get our location + my $latitude = $input{lat} ||= 0; + my $longitude = $input{lon} ||= 0; + if ( + !( $latitude || $longitude ) # have not been given lat or lon + && ( $input{easting} && $input{northing} ) # but do have e and n + ) + { + ( $latitude, $longitude ) = + Utils::convert_en_to_latlon( $input{easting}, $input{northing} ); + } + + # handle the photo upload + $c->forward( 'process_photo_upload', [ { rotate_photo => 1 } ] ); + my $photo = $c->stash->{upload_fileid}; + if ( my $error = $c->stash->{photo_error} ) { + push @errors, $error; + } + + push @errors, 'You must supply a service' unless $input{service}; + push @errors, 'Please enter a subject' unless $input{subject} =~ /\S/; + push @errors, 'Please enter your name' unless $input{name} =~ /\S/; + + if ( $input{email} !~ /\S/ ) { + push @errors, 'Please enter your email'; + } + elsif ( !mySociety::EmailUtil::is_valid_email( $input{email} ) ) { + push @errors, 'Please enter a valid email'; + } + + if ( $latitude && $c->cobrand->country eq 'GB' ) { + eval { Utils::convert_latlon_to_en( $latitude, $longitude ); }; + push @errors, + "We had a problem with the supplied co-ordinates - outside the UK?" + if $@; + } + + unless ( $photo || ( $latitude || $longitude ) ) { + push @errors, 'Either a location or a photo must be provided.'; + } + + # if we have errors then we should bail out + if (@errors) { + my $body = join '', map { "ERROR:$_\n" } @errors; + $c->res->body($body); + return; + } + +### leaving commented out for now as the values stored here never appear to +### get used and the new user accounts might make them redundant anyway. + # + # # Store for possible future use + # if ( $input{id} || $input{phone_id} ) { + # my $id = $input{id} || $input{phone_id}; + # my $already = + # dbh() + # ->selectrow_array( + # 'select id from partial_user where service=? and nsid=?', + # {}, $input{service}, $id ); + # unless ($already) { + # dbh()->do( + # 'insert into partial_user (service, nsid, name, email, phone)' + # . ' values (?, ?, ?, ?, ?)', + # {}, + # $input{service}, + # $id, + # $input{name}, + # $input{email}, + # $input{phone} + # ); + # } + # } + + # find or create the user + my $report_user = $c->model('DB::User')->find_or_create( + { + email => $input{email}, + name => $input{name}, + phone => $input{phone} + } + ); + + # create a new report (don't save it yet) + my $report = $c->model('DB::Problem')->new( + { + user => $report_user, + postcode => '', + latitude => $latitude, + longitude => $longitude, + title => $input{subject}, + detail => $input{detail}, + name => $input{name}, + service => $input{service}, + state => 'partial', + used_map => 1, + anonymous => 0, + category => '', + areas => '', + cobrand => $c->cobrand->moniker, + lang => $c->stash->{lang_code}, + + } + ); + + # If there was a photo add that too + if ( $photo ) { + my $file = file( $c->config->{UPLOAD_CACHE}, "$photo.jpg" ); + my $blob = $file->slurp; + $file->remove; + $report->photo($blob); + } + + # save the report; + $report->insert(); + + my $token = + $c->model("DB::Token") + ->create( { scope => 'partial', data => $report->id } ); + + $c->stash->{report} = $report; + $c->stash->{token_url} = $c->uri_for_email( '/L', $token->token ); + + $c->send_email( 'partial.txt', { to => $report->user->email, } ); + + $c->res->body('SUCCESS'); + return 1; +} + +=head2 initialize_report + +Create the report and set up some basics in it. If there is a partial report +requested then use that . + +Partial reports are created when people submit to us e.g. via mobile apps. +They are in the database but are not completed yet. Users reach us by following +a link we email them that contains a token link. This action looks for the +token and if found retrieves the report in it. + +=cut + +sub initialize_report : Private { + my ( $self, $c ) = @_; + + # check to see if there is a partial report that we should use, otherwise + # create a new one. Stick it on the stash. + my $report = undef; + + if ( my $partial = scalar $c->req->param('partial') ) { + + for (1) { # use as pseudo flow control + + # did we find a token + last unless $partial; + + # is it in the database + my $token = + $c->model("DB::Token") + ->find( { scope => 'partial', token => $partial } ) # + || last; + + # can we get an id from it? + my $id = $token->data # + || last; + + # load the related problem + $report = $c->cobrand->problems # + ->search( { id => $id, state => 'partial' } ) # + ->first; + + if ($report) { + + # log the problem creation user in to the site + $c->authenticate( { email => $report->user->email }, + 'no_password' ); + + # save the token to delete at the end + $c->stash->{partial_token} = $token if $report; + + } + else { + + # no point keeping it if it is done. + $token->delete; + } + } + } + + if ( !$report ) { + + # If we didn't find a partial then create a new one + $report = $c->model('DB::Problem')->new( {} ); + + # If we have a user logged in let's prefill some values for them. + if ( $c->user ) { + my $user = $c->user->obj; + $report->user($user); + $report->name( $user->name ); + } + + } + + # Capture whether the map was used + $report->used_map( $c->req->param('skipped') ? 0 : 1 ); + + $c->stash->{report} = $report; + + return 1; +} + +=head2 determine_location + +Work out what the location of the report should be - either by using lat,lng or +a tile click or what's come in from a partial. Returns false if no location +could be found. + +=cut + +sub determine_location : Private { + my ( $self, $c ) = @_; + + $c->stash->{fetch_all_areas} = 1; + return 1 + if # + ( # + $c->forward('determine_location_from_tile_click') + || $c->forward('/location/determine_location_from_coords') + || $c->forward('determine_location_from_report') + ) # + && $c->forward('/around/check_location_is_acceptable'); + return; +} + +=head2 determine_location_from_tile_click + +Detect that the map tiles have been clicked on by looking for the tile +parameters. + +=cut + +sub determine_location_from_tile_click : Private { + my ( $self, $c ) = @_; + + # example: 'tile_1673.1451.x' + my $param_key_regex = '^tile_(\d+)\.(\d+)\.[xy]$'; + + my @matching_param_keys = + grep { m/$param_key_regex/ } keys %{ $c->req->params }; + + # did we find any matches + return unless scalar(@matching_param_keys) == 2; + + # get the x and y keys + my ( $x_key, $y_key ) = sort @matching_param_keys; + + # Extract the data needed + my ( $pin_tile_x, $pin_tile_y ) = $x_key =~ m{$param_key_regex}; + my $pin_x = $c->req->param($x_key); + my $pin_y = $c->req->param($y_key); + + # return if they are both 0 - this happens when you submit the form by + # hitting enter and not using the button. It also happens if you click + # exactly there on the map but that is less likely than hitting return to + # submit. Lesser of two evils... + return unless $pin_x && $pin_y; + + # convert the click to lat and lng + my ( $latitude, $longitude ) = FixMyStreet::Map::click_to_wgs84( + $c, + $pin_tile_x, $pin_x, $pin_tile_y, $pin_y + ); + + # store it on the stash + $c->stash->{latitude} = $latitude; + $c->stash->{longitude} = $longitude; + + # set a flag so that the form is not considered submitted. This will prevent + # errors showing on the fields. + $c->stash->{force_form_not_submitted} = 1; + + # return true as we found a location + return 1; +} + +=head2 determine_location_from_report + +Use latitude and longitude stored in the report - this is probably result of a +partial report being loaded. + +=cut + +sub determine_location_from_report : Private { + my ( $self, $c ) = @_; + + my $report = $c->stash->{report}; + + if ( defined $report->latitude && defined $report->longitude ) { + $c->stash->{latitude} = $report->latitude; + $c->stash->{longitude} = $report->longitude; + return 1; + } + + return; +} + +=head2 setup_categories_and_councils + +Look up categories for this council or councils + +=cut + +sub setup_categories_and_councils : Private { + my ( $self, $c ) = @_; + + my $all_councils = $c->stash->{all_councils}; + my $first_council = ( values %$all_councils )[0]; + + my @contacts # + = $c # + ->model('DB::Contact') # + ->not_deleted # + ->search( { area_id => [ keys %$all_councils ] } ) # + ->all; + + # variables to populate + my %area_ids_to_list = (); # Areas with categories assigned + my @category_options = (); # categories to show + my $category_label = undef; # what to call them + + # FIXME - implement in cobrand + if ( $c->cobrand->moniker eq 'emptyhomes' ) { + + # add all areas found to the list + foreach (@contacts) { + $area_ids_to_list{ $_->area_id } = 1; + } + + # set our own categories + @category_options = ( + _('-- Pick a property type --'), + _('Empty house or bungalow'), + _('Empty flat or maisonette'), + _('Whole block of empty flats'), + _('Empty office or other commercial'), + _('Empty pub or bar'), + _('Empty public building - school, hospital, etc.') + ); + $category_label = _('Property type:'); + + } elsif ($first_council->{type} eq 'LBO') { + + $area_ids_to_list{ $first_council->{id} } = 1; + @category_options = ( + _('-- Pick a category --'), + sort keys %{ Utils::london_categories() } + ); + $category_label = _('Category:'); + + } else { + + # keysort does not appear to obey locale so use strcoll (see i18n.t) + @contacts = sort { strcoll( $a->category, $b->category ) } @contacts; + + my %seen; + foreach my $contact (@contacts) { + + $area_ids_to_list{ $contact->area_id } = 1; + + next # TODO - move this to the cobrand + if $c->cobrand->moniker eq 'southampton' + && $contact->category =~ /Street lighting|Traffic lights/; + + next if $contact->category eq _('Other'); + + push @category_options, $contact->category + unless $seen{$contact->category}; + $seen{$contact->category} = 1; + } + + if (@category_options) { + @category_options = + ( _('-- Pick a category --'), @category_options, _('Other') ); + $category_label = _('Category:'); + } + } + + # put results onto stash for display + $c->stash->{area_ids_to_list} = [ keys %area_ids_to_list ]; + $c->stash->{category_label} = $category_label; + $c->stash->{category_options} = \@category_options; + + my @missing_details_councils = + grep { !$area_ids_to_list{$_} } # + keys %$all_councils; + + my @missing_details_council_names = + map { $all_councils->{$_}->{name} } # + @missing_details_councils; + + $c->stash->{missing_details_councils} = \@missing_details_councils; + $c->stash->{missing_details_council_names} = \@missing_details_council_names; +} + +=head2 check_form_submitted + + $bool = $c->forward('check_form_submitted'); + +Returns true if the form has been submitted, false if not. Determines this based +on the presence of the C<submit_problem> parameter. + +=cut + +sub check_form_submitted : Private { + my ( $self, $c ) = @_; + return if $c->stash->{force_form_not_submitted}; + return $c->req->param('submit_problem') || ''; +} + +=head2 process_user + +Load user from the database or prepare a new one. + +=cut + +sub process_user : Private { + my ( $self, $c ) = @_; + + my $report = $c->stash->{report}; + + # The user is already signed in + if ( $c->user_exists ) { + my $user = $c->user->obj; + my %params = map { $_ => scalar $c->req->param($_) } ( 'name', 'phone' ); + $user->name( Utils::trim_text( $params{name} ) ) if $params{name}; + $user->phone( Utils::trim_text( $params{phone} ) ); + $report->user( $user ); + $report->name( $user->name ); + return 1; + } + + # Extract all the params to a hash to make them easier to work with + my %params = map { $_ => scalar $c->req->param($_) } + ( 'email', 'name', 'phone', 'password_register' ); + + # cleanup the email address + my $email = $params{email} ? lc $params{email} : ''; + $email =~ s{\s+}{}g; + + $report->user( $c->model('DB::User')->find_or_new( { email => $email } ) ) + unless $report->user; + + # The user is trying to sign in. We only care about email from the params. + if ( $c->req->param('submit_sign_in') || $c->req->param('password_sign_in') ) { + unless ( $c->forward( '/auth/sign_in' ) ) { + $c->stash->{field_errors}->{password} = _('There was a problem with your email/password combination. Passwords and user accounts are a brand <strong>new</strong> service, so you probably do not have one yet – please fill in the right hand side of this form to get one.'); + return 1; + } + my $user = $c->user->obj; + $report->user( $user ); + $report->name( $user->name ); + $c->stash->{field_errors}->{name} = _('You have successfully signed in; please check and confirm your details are accurate:'); + return 1; + } + + # set the user's name, phone, and password + $report->user->name( Utils::trim_text( $params{name} ) ) if $params{name}; + $report->user->phone( Utils::trim_text( $params{phone} ) ); + $report->user->password( Utils::trim_text( $params{password_register} ) ); + $report->name( Utils::trim_text( $params{name} ) ); + + return 1; +} + +=head2 process_report + +Looking at the parameters passed in create a new item and return it. Does not +save anything to the database. If no item can be created (ie no information +provided) returns undef. + +=cut + +sub process_report : Private { + my ( $self, $c ) = @_; + + # Extract all the params to a hash to make them easier to work with + my %params = # + map { $_ => scalar $c->req->param($_) } # + ( + 'title', 'detail', 'pc', # + 'detail_size', 'detail_depth', + 'may_show_name', # + 'category', # + 'partial', # + ); + + # load the report + my $report = $c->stash->{report}; + + # Enter the location and other bits which are not from the form + $report->postcode( $params{pc} ); + $report->latitude( $c->stash->{latitude} ); + $report->longitude( $c->stash->{longitude} ); + + # set some simple bool values (note they get inverted) + $report->anonymous( $params{may_show_name} ? 0 : 1 ); + + # clean up text before setting + $report->title( Utils::cleanup_text( $params{title} ) ); + + my $detail = Utils::cleanup_text( $params{detail}, { allow_multiline => 1 } ); + for my $w ('depth', 'size') { + next unless $params{"detail_$w"}; + next if $params{"detail_$w"} eq '-- Please select --'; + $detail .= "\n\n\u$w: " . $params{"detail_$w"}; + } + $report->detail( $detail ); + + # set these straight from the params + $report->category( _ $params{category} ); + + my $areas = $c->stash->{all_areas}; + $report->areas( ',' . join( ',', sort keys %$areas ) . ',' ); + + # From earlier in the process. + my $councils = $c->stash->{all_councils}; + my $first_council = ( values %$councils )[0]; + + if ( $c->cobrand->moniker eq 'emptyhomes' ) { + + $councils = join( ',', @{ $c->stash->{area_ids_to_list} } ) || -1; + $report->council( $councils ); + + } elsif ( $first_council->{type} eq 'LBO') { + + unless ( Utils::london_categories()->{ $report->category } ) { + $c->stash->{field_errors}->{category} = _('Please choose a category'); + } + $report->council( $first_council->{id} ); + + } elsif ( $report->category ) { + + # FIXME All contacts were fetched in setup_categories_and_councils, + # so can this DB call also be avoided? + my @contacts = $c-> # + model('DB::Contact') # + ->not_deleted # + ->search( + { + area_id => [ keys %$councils ], + category => $report->category + } + )->all; + + unless ( @contacts ) { + $c->stash->{field_errors}->{category} = _('Please choose a category'); + $report->council( -1 ); + return 1; + } + + # construct the council string: + # 'x,x' - x are council IDs that have this category + # 'x,x|y,y' - x are council IDs that have this category, y council IDs with *no* contact + my $council_string = join( ',', map { $_->area_id } @contacts ); + $council_string .= + '|' . join( ',', @{ $c->stash->{missing_details_councils} } ) + if $council_string && @{ $c->stash->{missing_details_councils} }; + $report->council($council_string); + + } elsif ( @{ $c->stash->{area_ids_to_list} } ) { + + # There was an area with categories, but we've not been given one. Bail. + $c->stash->{field_errors}->{category} = _('Please choose a category'); + + } else { + + # If we're here, we've been submitted somewhere + # where we have no contact information at all. + $report->council( -1 ); + + } + + # set defaults that make sense + $report->state('unconfirmed'); + + # save the cobrand and language related information + $report->cobrand( $c->cobrand->moniker ); + $report->cobrand_data( $c->cobrand->extra_problem_data ); + $report->lang( $c->stash->{lang_code} ); + + return 1; +} + +=head2 process_photo + +Handle the photo - either checking and storing it after an upload or retrieving +it from the cache. + +Store any error message onto 'photo_error' in stash. +=cut + +sub process_photo : Private { + my ( $self, $c ) = @_; + + return + $c->forward('process_photo_upload') + || $c->forward('process_photo_cache') + || 1; # always return true +} + +sub process_photo_upload : Private { + my ( $self, $c, $args ) = @_; + + # setup args and set defaults + $args ||= {}; + $args->{rotate_photo} ||= 0; + + # check for upload or return + my $upload = $c->req->upload('photo') + || return; + + # check that the photo is a jpeg + my $ct = $upload->type; + unless ( $ct eq 'image/jpeg' || $ct eq 'image/pjpeg' ) { + $c->stash->{photo_error} = _('Please upload a JPEG image only'); + return; + } + + # convert the photo into a blob (also resize etc) + my $photo_blob = + eval { _process_photo( $upload->fh, $args->{rotate_photo} ) }; + if ( my $error = $@ ) { + my $format = _( +"That image doesn't appear to have uploaded correctly (%s), please try again." + ); + $c->stash->{photo_error} = sprintf( $format, $error ); + return; + } + + # we have an image we can use - save it to the cache in case there is an + # error + my $cache_dir = dir( $c->config->{UPLOAD_CACHE} ); + $cache_dir->mkpath; + unless ( -d $cache_dir && -w $cache_dir ) { + warn "Can't find/write to photo cache directory '$cache_dir'"; + return; + } + + # create a random name and store the file there + my $fileid = int rand 1_000_000_000; + my $file = $cache_dir->file("$fileid.jpg"); + $file->openw->print($photo_blob); + + # stick the random number on the stash + $c->stash->{upload_fileid} = $fileid; + + return 1; +} + +=head2 process_photo_cache + +Look for the upload_fileid parameter and check it matches a file on disk. If it +does return true and put fileid on stash, otherwise false. + +=cut + +sub process_photo_cache : Private { + my ( $self, $c ) = @_; + + # get the fileid and make sure it is just a number + my $fileid = $c->req->param('upload_fileid') || ''; + $fileid =~ s{\D+}{}g; + return unless $fileid; + + my $file = file( $c->config->{UPLOAD_CACHE}, "$fileid.jpg" ); + return unless -e $file; + + $c->stash->{upload_fileid} = $fileid; + return 1; +} + +=head2 check_for_errors + +Examine the user and the report for errors. If found put them on stash and +return false. + +=cut + +sub check_for_errors : Private { + my ( $self, $c ) = @_; + + # let the model check for errors + $c->stash->{field_errors} ||= {}; + my %field_errors = ( + %{ $c->stash->{field_errors} }, + %{ $c->stash->{report}->user->check_for_errors }, + %{ $c->stash->{report}->check_for_errors }, + ); + + # add the photo error if there is one. + if ( my $photo_error = delete $c->stash->{photo_error} ) { + $field_errors{photo} = $photo_error; + } + + # all good if no errors + return 1 unless scalar keys %field_errors; + + $c->stash->{field_errors} = \%field_errors; + + return; +} + +=head2 save_user_and_report + +Save the user and the report. + +Be smart about the user - only set the name and phone if user did not exist +before or they are currently logged in. Otherwise discard any changes. + +=cut + +sub save_user_and_report : Private { + my ( $self, $c ) = @_; + my $report = $c->stash->{report}; + + # Save or update the user if appropriate + if ( !$report->user->in_storage ) { + $report->user->insert(); + } + elsif ( $c->user && $report->user->id == $c->user->id ) { + $report->user->update(); + $report->confirm; + } + else { + # User exists and we are not logged in as them. + # Store changes in token for when token is validated. + $c->stash->{token_data} = { + name => $report->user->name, + phone => $report->user->phone, + password => $report->user->password, + }; + $report->user->discard_changes(); + } + + # If there was a photo add that too + if ( my $fileid = $c->stash->{upload_fileid} ) { + my $file = file( $c->config->{UPLOAD_CACHE}, "$fileid.jpg" ); + my $blob = $file->slurp; + $file->remove; + $report->photo($blob); + } + + # Set a default if possible + $report->category( _('Other') ) unless $report->category; + + # Set unknown to DB unknown + $report->council( undef ) if $report->council eq '-1'; + + # save the report; + $report->in_storage ? $report->update : $report->insert(); + + # tidy up + if ( my $token = $c->stash->{partial_token} ) { + $token->delete; + } + + return 1; +} + +=head2 generate_map + +Add the html needed to for the map to the stash. + +=cut + +# Perhaps also create a map 'None' to use when map is skipped. + +sub generate_map : Private { + my ( $self, $c ) = @_; + my $latitude = $c->stash->{latitude}; + my $longitude = $c->stash->{longitude}; + + ( $c->stash->{short_latitude}, $c->stash->{short_longitude} ) = + map { Utils::truncate_coordinate($_) } + ( $c->stash->{latitude}, $c->stash->{longitude} ); + + # Don't do anything if the user skipped the map + unless ( $c->req->param('skipped') ) { + $c->stash->{page} = 'new'; + FixMyStreet::Map::display_map( + $c, + latitude => $latitude, + longitude => $longitude, + clickable => 1, + pins => [ { + latitude => $latitude, + longitude => $longitude, + colour => 'purple', + } ], + ); + } + + return 1; +} + +=head2 redirect_or_confirm_creation + +Now that the report has been created either redirect the user to its page if it +has been confirmed or email them a token if it has not been. + +=cut + +sub redirect_or_confirm_creation : Private { + my ( $self, $c ) = @_; + my $report = $c->stash->{report}; + + # If confirmed send the user straight there. + if ( $report->confirmed ) { + # Subscribe problem reporter to email updates + $c->forward( 'create_reporter_alert' ); + my $report_uri = $c->uri_for( '/report', $report->id ); + $c->res->redirect($report_uri); + $c->detach; + } + + # otherwise create a confirm token and email it to them. + my $data = $c->stash->{token_data} || {}; + my $token = $c->model("DB::Token")->create( { + scope => 'problem', + data => { + %$data, + id => $report->id + } + } ); + $c->stash->{token_url} = $c->uri_for_email( '/P', $token->token ); + $c->send_email( 'problem-confirm.txt', { + to => [ [ $report->user->email, $report->name ] ], + } ); + + # tell user that they've been sent an email + $c->stash->{template} = 'email_sent.html'; + $c->stash->{email_type} = 'problem'; +} + +sub create_reporter_alert : Private { + my ( $self, $c ) = @_; + + my $problem = $c->stash->{report}; + my $alert = $c->model('DB::Alert')->find_or_create( { + user => $problem->user, + alert_type => 'new_updates', + parameter => $problem->id, + cobrand => $problem->cobrand, + cobrand_data => $problem->cobrand_data, + lang => $problem->lang, + } )->confirm; +} + +=head2 redirect_to_around + +Redirect the user to '/around' passing along all the relevant parameters. + +=cut + +sub redirect_to_around : Private { + my ( $self, $c ) = @_; + + my $params = { + pc => ( $c->stash->{pc} || $c->req->param('pc') || '' ), + lat => $c->stash->{latitude}, + lon => $c->stash->{longitude}, + }; + + # delete empty values + for ( keys %$params ) { + delete $params->{$_} if !$params->{$_}; + } + + if ( my $token = $c->stash->{partial_token} ) { + $params->{partial} = $token->token; + } + + my $around_uri = $c->uri_for( '/around', $params ); + + return $c->res->redirect($around_uri); +} + +sub _process_photo { + my $fh = shift; + my $import = shift; + + my $blob = join('', <$fh>); + close $fh; + my ($handle, $filename) = mySociety::TempFiles::named_tempfile('.jpeg'); + print $handle $blob; + close $handle; + + my $photo = Image::Magick->new; + my $err = $photo->Read($filename); + unlink $filename; + throw Error::Simple("read failed: $err") if "$err"; + $err = $photo->Scale(geometry => "250x250>"); + throw Error::Simple("resize failed: $err") if "$err"; + my @blobs = $photo->ImageToBlob(); + undef $photo; + $photo = $blobs[0]; + return $photo unless $import; # Only check orientation for iPhone imports at present + + # Now check if it needs orientating + ($fh, $filename) = mySociety::TempFiles::named_tempfile('.jpeg'); + print $fh $photo; + close $fh; + my $out = `jhead -se -autorot $filename`; + if ($out) { + open(FP, $filename) or throw Error::Simple($!); + $photo = join('', <FP>); + close FP; + } + unlink $filename; + return $photo; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Report/Update.pm b/perllib/FixMyStreet/App/Controller/Report/Update.pm new file mode 100644 index 000000000..501dd2b41 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Report/Update.pm @@ -0,0 +1,343 @@ +package FixMyStreet::App::Controller::Report::Update; + +use Moose; +use namespace::autoclean; +BEGIN { extends 'Catalyst::Controller'; } + +use Path::Class; +use Utils; + +=head1 NAME + +FixMyStreet::App::Controller::Report::Update + +=head1 DESCRIPTION + +Creates an update to a report + +=cut + +sub report_update : Path : Args(0) { + my ( $self, $c ) = @_; + + $c->forward( '/report/load_problem_or_display_error', [ $c->req->param('id') ] ); + $c->forward('process_update'); + $c->forward('process_user'); + $c->forward('/report/new/process_photo'); + $c->forward('check_for_errors') + or $c->go( '/report/display', [ $c->req->param('id') ] ); + + $c->forward('save_update'); + $c->forward('redirect_or_confirm_creation'); +} + +sub confirm : Private { + my ( $self, $c ) = @_; + + $c->stash->{update}->confirm; + $c->stash->{update}->update; + + $c->forward('update_problem'); + $c->forward('signup_for_alerts'); + + return 1; +} + +sub update_problem : Private { + my ( $self, $c ) = @_; + + my $display_questionnaire = 0; + + my $update = $c->stash->{update}; + my $problem = $c->stash->{problem} || $update->problem; + + if ( $update->mark_fixed ) { + $problem->state('fixed'); + + if ( $update->user->id == $problem->user->id ) { + $problem->send_questionnaire(0); + + if ( $c->cobrand->ask_ever_reported + && !$problem->user->answered_ever_reported ) + { + $display_questionnaire = 1; + } + } + } + + if ( $update->mark_open && $update->user->id == $problem->user->id ) { + $problem->state('confirmed'); + } + + $problem->lastupdate( \'ms_current_timestamp()' ); + $problem->update; + + $c->stash->{problem_id} = $problem->id; + + if ($display_questionnaire) { + $c->detach('/questionnaire/creator_fixed'); + } + + return 1; +} + +=head2 process_user + +Load user from the database or prepare a new one. + +=cut + +sub process_user : Private { + my ( $self, $c ) = @_; + + my $update = $c->stash->{update}; + + if ( $c->user_exists ) { + my $user = $c->user->obj; + my $name = scalar $c->req->param('name'); + $user->name( Utils::trim_text( $name ) ) if $name; + $update->user( $user ); + return 1; + } + + # Extract all the params to a hash to make them easier to work with + my %params = map { $_ => scalar $c->req->param($_) } + ( 'rznvy', 'name', 'password_register' ); + + # cleanup the email address + my $email = $params{rznvy} ? lc $params{rznvy} : ''; + $email =~ s{\s+}{}g; + + $update->user( $c->model('DB::User')->find_or_new( { email => $email } ) ) + unless $update->user; + + # The user is trying to sign in. We only care about email from the params. + if ( $c->req->param('submit_sign_in') || $c->req->param('password_sign_in') ) { + unless ( $c->forward( '/auth/sign_in', [ $email ] ) ) { + $c->stash->{field_errors}->{password} = _('There was a problem with your email/password combination. Passwords and user accounts are a brand <strong>new</strong> service, so you probably do not have one yet – please fill in the right hand side of this form to get one.'); + return 1; + } + my $user = $c->user->obj; + $update->user( $user ); + $update->name( $user->name ); + $c->stash->{field_errors}->{name} = _('You have successfully signed in; please check and confirm your details are accurate:'); + return 1; + } + + $update->user->name( Utils::trim_text( $params{name} ) ) + if $params{name}; + $update->user->password( Utils::trim_text( $params{password_register} ) ); + + return 1; +} + +=head2 process_update + +Take the submitted params and create a new update item. Does not save +anything to the database. + +NB: relies on their being a problem and update_user in the stash. May +want to move adding these elsewhere + +=cut + +sub process_update : Private { + my ( $self, $c ) = @_; + + my %params = + map { $_ => scalar $c->req->param($_) } ( 'update', 'name', 'fixed', 'reopen' ); + + $params{update} = + Utils::cleanup_text( $params{update}, { allow_multiline => 1 } ); + + my $name = Utils::trim_text( $params{name} ); + my $anonymous = $c->req->param('may_show_name') ? 0 : 1; + + $params{reopen} = 0 unless $c->user && $c->user->id == $c->stash->{problem}->user->id; + + my $update = $c->model('DB::Comment')->new( + { + text => $params{update}, + name => $name, + problem => $c->stash->{problem}, + state => 'unconfirmed', + mark_fixed => $params{fixed} ? 1 : 0, + mark_open => $params{reopen} ? 1 : 0, + cobrand => $c->cobrand->moniker, + cobrand_data => $c->cobrand->extra_update_data, + lang => $c->stash->{lang_code}, + anonymous => $anonymous, + } + ); + + $c->stash->{update} = $update; + $c->stash->{add_alert} = $c->req->param('add_alert'); + + return 1; +} + + +=head2 check_for_errors + +Examine the user and the report for errors. If found put them on stash and +return false. + +=cut + +sub check_for_errors : Private { + my ( $self, $c ) = @_; + + # let the model check for errors + $c->stash->{field_errors} ||= {}; + my %field_errors = ( + %{ $c->stash->{field_errors} }, + %{ $c->stash->{update}->user->check_for_errors }, + %{ $c->stash->{update}->check_for_errors }, + ); + + if ( my $photo_error = delete $c->stash->{photo_error} ) { + $field_errors{photo} = $photo_error; + } + + # all good if no errors + return 1 + unless ( scalar keys %field_errors + || ( $c->stash->{errors} && scalar @{ $c->stash->{errors} } ) ); + + $c->stash->{field_errors} = \%field_errors; + + $c->stash->{errors} ||= []; + #push @{ $c->stash->{errors} }, + # _('There were problems with your update. Please see below.'); + + return; +} + +=head2 save_update + +Save the update and the user as appropriate. + +=cut + +sub save_update : Private { + my ( $self, $c ) = @_; + + my $update = $c->stash->{update}; + + if ( !$update->user->in_storage ) { + $update->user->insert; + } + elsif ( $c->user && $c->user->id == $update->user->id ) { + # Logged in and same user, so can confirm update straight away + $update->user->update; + $update->confirm; + } else { + # User exists and we are not logged in as them. + # Store changes in token for when token is validated. + $c->stash->{token_data} = { + name => $update->user->name, + password => $update->user->password, + }; + $update->user->discard_changes(); + } + + # If there was a photo add that too + if ( my $fileid = $c->stash->{upload_fileid} ) { + my $file = file( $c->config->{UPLOAD_CACHE}, "$fileid.jpg" ); + my $blob = $file->slurp; + $file->remove; + $update->photo($blob); + } + + if ( $update->in_storage ) { + $update->update; + } + else { + $update->insert; + } + + return 1; +} + +=head2 redirect_or_confirm_creation + +Now that the update has been created either redirect the user to problem page if it +has been confirmed or email them a token if it has not been. + +=cut + +sub redirect_or_confirm_creation : Private { + my ( $self, $c ) = @_; + my $update = $c->stash->{update}; + + # If confirmed send the user straight there. + if ( $update->confirmed ) { + $c->forward( 'update_problem' ); + $c->forward( 'signup_for_alerts' ); + my $report_uri = $c->uri_for( '/report', $update->problem_id ); + $c->res->redirect($report_uri); + $c->detach; + } + + # otherwise create a confirm token and email it to them. + my $data = $c->stash->{token_data} || {}; + my $token = $c->model("DB::Token")->create( + { + scope => 'comment', + data => { + %$data, + id => $update->id, + add_alert => ( $c->req->param('add_alert') ? 1 : 0 ), + } + } + ); + $c->stash->{token_url} = $c->uri_for_email( '/C', $token->token ); + $c->send_email( 'update-confirm.txt', { + to => $update->name + ? [ [ $update->user->email, $update->name ] ] + : $update->user->email, + } ); + + # tell user that they've been sent an email + $c->stash->{template} = 'email_sent.html'; + $c->stash->{email_type} = 'update'; + + return 1; +} + +=head2 signup_for_alerts + +If the user has selected to be signed up for alerts then create a +new_updates alert. Or if they're logged in and they've unticked the +box, disable their alert. + +NB: this does not check if they are a registered user so that should +happen before calling this. + +=cut + +sub signup_for_alerts : Private { + my ( $self, $c ) = @_; + + if ( $c->stash->{add_alert} ) { + my $update = $c->stash->{update}; + my $alert = $c->model('DB::Alert')->find_or_create( + user => $update->user, + alert_type => 'new_updates', + parameter => $update->problem_id, + cobrand => $update->cobrand, + cobrand_data => $update->cobrand_data, + lang => $update->lang, + ); + $alert->confirm(); + + } elsif ( $c->user && ( my $alert = $c->user->alert_for_problem($c->stash->{update}->problem_id) ) ) { + $alert->disable(); + } + + return 1; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Reports.pm b/perllib/FixMyStreet/App/Controller/Reports.pm new file mode 100644 index 000000000..61d7d5cb1 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Reports.pm @@ -0,0 +1,439 @@ +package FixMyStreet::App::Controller::Reports; +use Moose; +use namespace::autoclean; + +use File::Slurp; +use List::MoreUtils qw(zip); +use POSIX qw(strcoll); +use mySociety::MaPit; +use mySociety::VotingArea; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::Reports - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + +=head2 index + +Show the summary page of all reports. + +=cut + +sub index : Path : Args(0) { + my ( $self, $c ) = @_; + + $c->response->header('Cache-Control' => 'max-age=3600'); + + # Fetch all areas of the types we're interested in + my $areas_info; + eval { + my @area_types = $c->cobrand->area_types; + $areas_info = mySociety::MaPit::call('areas', \@area_types, + min_generation => $c->cobrand->area_min_generation + ); + }; + if ($@) { + $c->stash->{message} = _("Unable to look up areas in MaPit. Please try again later.") . ' ' . + sprintf(_('The error was: %s'), $@); + $c->stash->{template} = 'errors/generic.html'; + } + + # For each area, add its link and perhaps alter its name if we need to for + # places with the same name. + foreach (values %$areas_info) { + $_->{url} = $c->uri_for( '/reports/' . $c->cobrand->short_name( $_, $areas_info ) ); + if ($_->{parent_area} && $_->{url} =~ /,|%2C/) { + $_->{name} .= ', ' . $areas_info->{$_->{parent_area}}{name}; + } + } + + $c->stash->{areas_info} = $areas_info; + my @keys = sort { strcoll($areas_info->{$a}{name}, $areas_info->{$b}{name}) } keys %$areas_info; + $c->stash->{areas_info_sorted} = [ map { $areas_info->{$_} } @keys ]; + + eval { + my $data = File::Slurp::read_file( + FixMyStreet->path_to( '../data/all-reports.json' )->stringify + ); + my $j = JSON->new->utf8->decode($data); + $c->stash->{fixed} = $j->{fixed}; + $c->stash->{open} = $j->{open}; + }; + if ($@) { + $c->stash->{message} = _("There was a problem showing the All Reports page. Please try again later.") . ' ' . + sprintf(_('The error was: %s'), $@); + $c->stash->{template} = 'errors/generic.html'; + } +} + +=head2 index + +Show the summary page for a particular council. + +=cut + +sub council : Path : Args(1) { + my ( $self, $c, $council ) = @_; + $c->detach( 'ward', [ $council ] ); +} + +=head2 index + +Show the summary page for a particular ward. + +=cut + +sub ward : Path : Args(2) { + my ( $self, $c, $council, $ward ) = @_; + + $c->forward( 'council_check', [ $council ] ); + $c->forward( 'ward_check', [ $ward ] ) + if $ward; + $c->forward( 'load_parent' ); + $c->forward( 'check_canonical_url', [ $council ] ); + $c->forward( 'load_and_group_problems' ); + $c->forward( 'sort_problems' ); + + my $council_short = $c->cobrand->short_name( $c->stash->{council}, $c->stash->{areas_info} ); + $c->stash->{rss_url} = '/rss/reports/' . $council_short; + $c->stash->{rss_url} .= '/' . $c->cobrand->short_name( $c->stash->{ward} ) + if $c->stash->{ward}; + + $c->stash->{council_url} = '/reports/' . $council_short; + + my $pins = $c->stash->{pins}; + + $c->stash->{page} = 'reports'; # So the map knows to make clickable pins + FixMyStreet::Map::display_map( + $c, + latitude => @$pins ? $pins->[0]{latitude} : 0, + longitude => @$pins ? $pins->[0]{longitude} : 0, + area => $c->stash->{ward} ? $c->stash->{ward}->{id} : $c->stash->{council}->{id}, + pins => $pins, + any_zoom => 1, + ); + + # List of wards + unless ($c->stash->{ward}) { + my $children = mySociety::MaPit::call('area/children', $c->stash->{council}->{id} ); + foreach (values %$children) { + $_->{url} = $c->uri_for( $c->stash->{council_url} + . '/' . $c->cobrand->short_name( $_ ) + ); + } + $c->stash->{children} = $children; + } +} + +sub rss_council : Regex('^rss/(reports|area)$') : Args(1) { + my ( $self, $c, $council ) = @_; + $c->detach( 'rss_ward', [ $council ] ); +} + +sub rss_ward : Regex('^rss/(reports|area)$') : Args(2) { + my ( $self, $c, $council, $ward ) = @_; + + my ( $rss ) = $c->req->captures->[0]; + + $c->stash->{rss} = 1; + + $c->forward( 'council_check', [ $council ] ); + $c->forward( 'ward_check', [ $ward ] ) if $ward; + + if ($rss eq 'area' && $c->stash->{council}{type} ne 'DIS' && $c->stash->{council}{type} ne 'CTY') { + # Two possibilites are the same for one-tier councils, so redirect one to the other + $c->detach( 'redirect_area' ); + } + + my $url = $c->cobrand->short_name( $c->stash->{council} ); + $url .= '/' . $c->cobrand->short_name( $c->stash->{ward} ) if $c->stash->{ward}; + $c->stash->{qs} = "/$url"; + + my @params; + push @params, $c->stash->{council}->{id} if $rss eq 'reports'; + push @params, $c->stash->{ward} + ? $c->stash->{ward}->{id} + : $c->stash->{council}->{id}; + $c->stash->{db_params} = [ @params ]; + + if ( $rss eq 'area' && $c->stash->{ward} ) { + # All problems within a particular ward + $c->stash->{type} = 'area_problems'; + $c->stash->{title_params} = { NAME => $c->stash->{ward}{name} }; + $c->stash->{db_params} = [ $c->stash->{ward}->{id} ]; + } elsif ( $rss eq 'area' ) { + # Problems within a particular council + $c->stash->{type} = 'area_problems'; + $c->stash->{title_params} = { NAME => $c->stash->{council}{name} }; + $c->stash->{db_params} = [ $c->stash->{council}->{id} ]; + } elsif ($c->stash->{ward}) { + # Problems sent to a council, restricted to a ward + $c->stash->{type} = 'ward_problems'; + $c->stash->{title_params} = { COUNCIL => $c->stash->{council}{name}, WARD => $c->stash->{ward}{name} }; + $c->stash->{db_params} = [ $c->stash->{council}->{id}, $c->stash->{ward}->{id} ]; + } else { + # Problems sent to a council + $c->stash->{type} = 'council_problems'; + $c->stash->{title_params} = { COUNCIL => $c->stash->{council}{name} }; + $c->stash->{db_params} = [ $c->stash->{council}->{id}, $c->stash->{council}->{id} ]; + } + + # Send on to the RSS generation + $c->forward( '/rss/output' ); +} + +=head2 council_check + +This action checks the council name (or code) given in a URI exists, is valid +and so on. If it is, it stores the Area in the stash, otherwise it redirects +to the all reports page. + +=cut + +sub council_check : Private { + my ( $self, $c, $q_council ) = @_; + + $q_council =~ s/\+/ /g; + $q_council =~ s/\.html//; + + # Manual misspelling redirect + if ($q_council =~ /^rhondda cynon taff$/i) { + my $url = $c->uri_for( '/reports/rhondda+cynon+taf' ); + $c->res->redirect( $url ); + $c->detach(); + } + + # Check cobrand specific incantations - e.g. ONS codes for UK, + # Oslo/ kommunes sharing a name in Norway + return if $c->cobrand->reports_council_check( $c, $q_council ); + + # If we're passed an ID number (don't think this is used anywhere, it + # certainly shouldn't be), just look that up on MaPit and redirect + if ($q_council =~ /^\d+$/) { + my $council = mySociety::MaPit::call('area', $q_council); + $c->detach( 'redirect_index') if $council->{error}; + $c->stash->{council} = $council; + $c->detach( 'redirect_area' ); + } + + # We must now have a string to check + my @area_types = $c->cobrand->area_types; + my $areas = mySociety::MaPit::call( 'areas', $q_council, + type => \@area_types, + min_generation => $c->cobrand->area_min_generation + ); + if (keys %$areas == 1) { + ($c->stash->{council}) = values %$areas; + return; + } else { + foreach (keys %$areas) { + if (lc($areas->{$_}->{name}) eq lc($q_council) || $areas->{$_}->{name} =~ /^\Q$q_council\E (Borough|City|District|County) Council$/i) { + $c->stash->{council} = $areas->{$_}; + return; + } + } + } + + # No result, bad council name. + $c->detach( 'redirect_index' ); +} + +=head2 ward_check + +This action checks the ward name from a URI exists and is part of the right +parent, already found with council_check. It either stores the ward Area if +okay, or redirects to the council page if bad. +This is currently only used in the UK, hence the use of mySociety::VotingArea. + +=cut + +sub ward_check : Private { + my ( $self, $c, $ward ) = @_; + + $ward =~ s/\+/ /g; + $ward =~ s/\.html//; + $ward =~ s{_}{/}g; + + my $council = $c->stash->{council}; + + my $qw = mySociety::MaPit::call('areas', $ward, + type => $mySociety::VotingArea::council_child_types, + min_generation => $c->cobrand->area_min_generation + ); + foreach my $id (sort keys %$qw) { + if ($qw->{$id}->{parent_area} == $council->{id}) { + $c->stash->{ward} = $qw->{$id}; + return; + } + } + # Given a false ward name + $c->detach( 'redirect_area' ); +} + +sub load_parent : Private { + my ( $self, $c ) = @_; + + my $council = $c->stash->{council}; + my $areas_info; + if ($council->{parent_area}) { + $c->stash->{areas_info} = mySociety::MaPit::call('areas', [ $council->{id}, $council->{parent_area} ]) + } else { + $c->stash->{areas_info} = { $council->{id} => $council }; + } +} + +=head2 check_canonical_url + +Given an already found (case-insensitively) council, check what URL +we are at and redirect accordingly if different. + +=cut + +sub check_canonical_url : Private { + my ( $self, $c, $q_council ) = @_; + + my $council_short = $c->cobrand->short_name( $c->stash->{council}, $c->stash->{areas_info} ); + my $url_short = URI::Escape::uri_escape_utf8($q_council); + $url_short =~ s/%2B/+/g; + $c->detach( 'redirect_area' ) unless $council_short eq $url_short; +} + +sub load_and_group_problems : Private { + my ( $self, $c ) = @_; + + my $page = $c->req->params->{p} || 1; + + my $where = { + state => [ 'confirmed', 'fixed' ] + }; + if ($c->stash->{ward}) { + $where->{areas} = { 'like', '%,' . $c->stash->{ward}->{id} . ',%' }; + } elsif ($c->stash->{council}) { + $where->{areas} = { 'like', '%,' . $c->stash->{council}->{id} . ',%' }; + } + my $problems = $c->cobrand->problems->search( + $where, + { + columns => [ + 'id', 'council', 'state', 'areas', 'latitude', 'longitude', 'title', + { duration => { extract => "epoch from current_timestamp-lastupdate" } }, + { age => { extract => "epoch from current_timestamp-confirmed" } }, + ], + order_by => { -desc => 'lastupdate' }, + rows => 100, + } + )->page( $page ); + $c->stash->{pager} = $problems->pager; + $problems = $problems->cursor; # Raw DB cursor for speed + + my ( %fixed, %open, @pins ); + my $re_councils = join('|', keys %{$c->stash->{areas_info}}); + my @cols = ( 'id', 'council', 'state', 'areas', 'latitude', 'longitude', 'title', 'duration', 'age' ); + while ( my @problem = $problems->next ) { + my %problem = zip @cols, @problem; + if ( !$problem{council} ) { + # Problem was not sent to any council, add to possible councils + $problem{councils} = 0; + while ($problem{areas} =~ /,($re_councils)(?=,)/g) { + add_row( \%problem, $1, \%fixed, \%open, \@pins ); + } + } else { + # Add to councils it was sent to + (my $council = $problem{council}) =~ s/\|.*$//; + my @council = split( /,/, $council ); + $problem{councils} = scalar @council; + foreach ( @council ) { + next if $c->stash->{council} && $_ != $c->stash->{council}->{id}; + add_row( \%problem, $_, \%fixed, \%open, \@pins ); + } + } + } + + $c->stash( + fixed => \%fixed, + open => \%open, + pins => \@pins, + ); + + return 1; +} + +sub sort_problems : Private { + my ( $self, $c ) = @_; + + my $id = $c->stash->{council}->{id}; + my $fixed = $c->stash->{fixed}; + my $open = $c->stash->{open}; + + foreach (qw/new old/) { + $c->stash->{fixed}{$id}{$_} = [ sort { $a->{duration} <=> $b->{duration} } @{$fixed->{$id}{$_}} ] + if $fixed->{$id}{$_}; + } + foreach (qw/new older unknown/) { + $c->stash->{open}{$id}{$_} = [ sort { $a->{age} <=> $b->{age} } @{$open->{$id}{$_}} ] + if $open->{$id}{$_}; + } +} + +sub redirect_index : Private { + my ( $self, $c ) = @_; + my $url = '/reports'; + $c->res->redirect( $c->uri_for($url) ); +} + +sub redirect_area : Private { + my ( $self, $c ) = @_; + my $url = ''; + $url .= "/rss" if $c->stash->{rss}; + $url .= '/reports'; + $url .= '/' . $c->cobrand->short_name( $c->stash->{council}, $c->stash->{areas_info} ); + $url .= '/' . $c->cobrand->short_name( $c->stash->{ward} ) + if $c->stash->{ward}; + $c->res->redirect( $c->uri_for($url) ); +} + +my $fourweeks = 4*7*24*60*60; +sub add_row { + my ( $problem, $council, $fixed, $open, $pins ) = @_; + my $duration_str = ( $problem->{duration} > 2 * $fourweeks ) ? 'old' : 'new'; + my $type = ( $problem->{duration} > 2 * $fourweeks ) + ? 'unknown' + : ($problem->{age} > $fourweeks ? 'older' : 'new'); + # Fixed problems are either old or new + push @{$fixed->{$council}{$duration_str}}, $problem if $problem->{state} eq 'fixed'; + # Open problems are either unknown, older, or new + push @{$open->{$council}{$type}}, $problem if $problem->{state} eq 'confirmed'; + + push @$pins, { + latitude => $problem->{latitude}, + longitude => $problem->{longitude}, + colour => $problem->{state} eq 'fixed' ? 'green' : 'red', + id => $problem->{id}, + title => $problem->{title}, + }; +} + +=head1 AUTHOR + +Matthew Somerville + +=head1 LICENSE + +Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. +Licensed under the Affero GPL. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; + diff --git a/perllib/FixMyStreet/App/Controller/Root.pm b/perllib/FixMyStreet/App/Controller/Root.pm new file mode 100644 index 000000000..9cdf0b523 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Root.pm @@ -0,0 +1,108 @@ +package FixMyStreet::App::Controller::Root; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller' } + +__PACKAGE__->config( namespace => '' ); + +=head1 NAME + +FixMyStreet::App::Controller::Root - Root Controller for FixMyStreet::App + +=head1 DESCRIPTION + +[enter your description here] + +=head1 METHODS + +=head2 auto + +Set up general things for this instance + +=cut + +sub auto : Private { + my ( $self, $c ) = @_; + + # decide which cobrand this request should use + $c->setup_request(); + + return 1; +} + +=head2 index + +Home page. + +If request includes certain parameters redirect to '/around' - this is to +preserve old behaviour. + +=cut + +sub index : Path : Args(0) { + my ( $self, $c ) = @_; + + my @old_param_keys = ( 'pc', 'x', 'y', 'e', 'n', 'lat', 'lon' ); + my %old_params = (); + + foreach my $key (@old_param_keys) { + my $val = $c->req->param($key); + next unless $val; + $old_params{$key} = $val; + } + + if ( scalar keys %old_params ) { + my $around_uri = $c->uri_for( '/around', \%old_params ); + $c->res->redirect($around_uri); + return; + } + +} + +=head2 default + +Forward to the standard 404 error page + +=cut + +sub default : Path { + my ( $self, $c ) = @_; + $c->detach('/page_error_404_not_found'); +} + +=head2 page_error_404_not_found, page_error_410_gone + + $c->detach( '/page_error_404_not_found', [$error_msg] ); + $c->detach( '/page_error_410_gone', [$error_msg] ); + +Display a 404 (not found) or 410 (gone) page. Pass in an optional error message in an arrayref. + +=cut + +sub page_error_404_not_found : Private { + my ( $self, $c, $error_msg ) = @_; + $c->stash->{template} = 'errors/page_error_404_not_found.html'; + $c->stash->{error_msg} = $error_msg; + $c->response->status(404); +} + +sub page_error_410_gone : Private { + my ( $self, $c, $error_msg ) = @_; + $c->stash->{template} = 'index.html'; + $c->stash->{error} = $error_msg; + $c->response->status(410); +} + +=head2 end + +Attempt to render a view, if needed. + +=cut + +sub end : ActionClass('RenderView') { +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Rss.pm b/perllib/FixMyStreet/App/Controller/Rss.pm new file mode 100755 index 000000000..78793d9c1 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Rss.pm @@ -0,0 +1,342 @@ +package FixMyStreet::App::Controller::Rss; + +use Moose; +use namespace::autoclean; +use POSIX qw(strftime); +use URI::Escape; +use XML::RSS; + +use mySociety::Gaze; +use mySociety::Locale; +use mySociety::MaPit; +use mySociety::Sundries qw(ordinal); +use mySociety::Web qw(ent); + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::Rss - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + +sub updates : LocalRegex('^(\d+)$') { + my ( $self, $c ) = @_; + + my $id = $c->req->captures->[0]; + $c->forward( '/report/load_problem_or_display_error', [ $id ] ); + + $c->stash->{type} = 'new_updates'; + $c->stash->{qs} = 'report/' . $id; + $c->stash->{db_params} = [ $id ]; + $c->forward('output'); +} + +sub new_problems : Path('problems') : Args(0) { + my ( $self, $c ) = @_; + + $c->stash->{type} = 'new_problems'; + $c->forward('output'); +} + +# FIXME I don't think this is used - check +#sub reports_to_council : Private { +# my ( $self, $c ) = @_; +# +# my $id = $c->stash->{id}; +# $c->stash->{type} = 'council_problems'; +# $c->stash->{qs} = '/' . $id; +# $c->stash->{db_params} = [ $id ]; +# $c->forward('output'); +#} + +sub reports_in_area : LocalRegex('^area/(\d+)$') { + my ( $self, $c ) = @_; + + my $id = $c->req->captures->[0]; + my $area = mySociety::MaPit::call('area', $id); + $c->stash->{type} = 'area_problems'; + $c->stash->{qs} = '/' . $id; + $c->stash->{db_params} = [ $id ]; + $c->stash->{title_params} = { NAME => $area->{name} }; + $c->forward('output'); +} + +sub all_problems : Private { + my ( $self, $c ) = @_; + + $c->stash->{type} = 'all_problems'; + $c->forward('output'); +} + +sub local_problems_pc : Path('pc') : Args(1) { + my ( $self, $c, $query ) = @_; + $c->forward( 'local_problems_pc_distance', [ $query ] ); +} + +sub local_problems_pc_distance : Path('pc') : Args(2) { + my ( $self, $c, $query, $d ) = @_; + + $c->forward( 'get_query_parameters', [ $d ] ); + unless ( $c->forward( '/location/determine_location_from_pc', [ $query ] ) ) { + $c->res->redirect( '/alert' ); + $c->detach(); + } + + my $pretty_query = $query; + $pretty_query = mySociety::PostcodeUtil::canonicalise_postcode($query) + if mySociety::PostcodeUtil::is_valid_postcode($query); + + my $pretty_query_escaped = URI::Escape::uri_escape_utf8($pretty_query); + $pretty_query_escaped =~ s/%20/+/g; + + $c->stash->{qs} = "?pc=$pretty_query_escaped"; + $c->stash->{title_params} = { POSTCODE => $pretty_query }; + $c->stash->{type} = 'postcode_local_problems'; + + $c->forward( 'local_problems_ll', + [ $c->stash->{latitude}, $c->stash->{longitude} ] + ); + +} + +sub local_problems : LocalRegex('^(n|l)/([\d.-]+)[,/]([\d.-]+)(?:/(\d+))?$') { + my ( $self, $c ) = @_; + + my ( $type, $a, $b, $d) = @{ $c->req->captures }; + $c->forward( 'get_query_parameters', [ $d ] ); + + $c->detach( 'redirect_lat_lon', [ $a, $b ] ) + if $type eq 'n'; + + $c->stash->{qs} = "?lat=$a;lon=$b"; + $c->stash->{type} = 'local_problems'; + + $c->forward( 'local_problems_ll', [ $a, $b ] ); +} + +sub local_problems_ll : Private { + my ( $self, $c, $lat, $lon ) = @_; + + # truncate the lat,lon for nicer urls + ( $lat, $lon ) = map { Utils::truncate_coordinate($_) } ( $lat, $lon ); + + my $d = $c->stash->{distance}; + if ( $d ) { + $c->stash->{qs} .= ";d=$d"; + $d = 100 if $d > 100; + } else { + $d = mySociety::Gaze::get_radius_containing_population( $lat, $lon, 200000 ); + $d = int( $d * 10 + 0.5 ) / 10; + mySociety::Locale::in_gb_locale { + $d = sprintf("%f", $d); + } + } + + $c->stash->{db_params} = [ $lat, $lon, $d ]; + + if ($c->stash->{state} ne 'all') { + $c->stash->{type} .= '_state'; + push @{ $c->stash->{db_params} }, $c->stash->{state}; + } + + $c->forward('output'); +} + +sub output : Private { + my ( $self, $c ) = @_; + + $c->stash->{alert_type} = $c->model('DB::AlertType')->find( { ref => $c->stash->{type} } ); + $c->detach( '/page_error_404_not_found', [ _('Unknown alert type') ] ) + unless $c->stash->{alert_type}; + + $c->forward( 'query_main' ); + + # Do our own encoding + $c->stash->{rss} = new XML::RSS( + version => '2.0', + encoding => 'UTF-8', + stylesheet => $c->cobrand->feed_xsl, + encode_output => undef + ); + $c->stash->{rss}->add_module( + prefix => 'georss', + uri => 'http://www.georss.org/georss' + ); + + while (my $row = $c->stash->{query_main}->fetchrow_hashref) { + $c->forward( 'add_row', [ $row ] ); + } + + $c->forward( 'add_parameters' ); + + my $out = $c->stash->{rss}->as_string; + my $uri = $c->uri_for( '/' . $c->req->path ); + $out =~ s{<link>(.*?)</link>}{"<link>" . $c->uri_for( $1 ) . "</link><uri>$uri</uri>"}e; + + $c->response->header('Content-Type' => 'application/xml; charset=utf-8'); + $c->response->body( $out ); +} + +sub query_main : Private { + my ( $self, $c ) = @_; + my $alert_type = $c->stash->{alert_type}; + + my ( $site_restriction, $site_id ) = $c->cobrand->site_restriction( $c->cobrand->extra_data ); + # Only apply a site restriction if the alert uses the problem table + $site_restriction = '' unless $alert_type->item_table eq 'problem'; + + # FIXME Do this in a nicer way at some point in the future... + my $query = 'select * from ' . $alert_type->item_table . ' where ' + . ($alert_type->head_table ? $alert_type->head_table . '_id=? and ' : '') + . $alert_type->item_where . $site_restriction . ' order by ' + . $alert_type->item_order; + my $rss_limit = mySociety::Config::get('RSS_LIMIT'); + $query .= " limit $rss_limit" unless $c->stash->{type} =~ /^all/; + + my $q = $c->model('DB::Alert')->result_source->storage->dbh->prepare($query); + + $c->stash->{db_params} ||= []; + if ($query =~ /\?/) { + $c->detach( '/page_error_404_not_found', [ 'Missing parameter' ] ) + unless @{ $c->stash->{db_params} }; + $q->execute( @{ $c->stash->{db_params} } ); + } else { + $q->execute(); + } + $c->stash->{query_main} = $q; +} + +sub add_row : Private { + my ( $self, $c, $row ) = @_; + my $alert_type = $c->stash->{alert_type}; + + $row->{name} = 'anonymous' if $row->{anonymous} || !$row->{name}; + + my $pubDate; + if ($row->{confirmed}) { + $row->{confirmed} =~ /^(\d\d\d\d)-(\d\d)-(\d\d) (\d\d):(\d\d):(\d\d)/; + $pubDate = mySociety::Locale::in_gb_locale { + strftime("%a, %d %b %Y %H:%M:%S %z", $6, $5, $4, $3, $2-1, $1-1900, -1, -1, 0) + }; + $row->{confirmed} = strftime("%e %B", $6, $5, $4, $3, $2-1, $1-1900, -1, -1, 0); + $row->{confirmed} =~ s/^\s+//; + $row->{confirmed} =~ s/^(\d+)/ordinal($1)/e if $c->stash->{lang_code} eq 'en-gb'; + } + + (my $title = _($alert_type->item_title)) =~ s/{{(.*?)}}/$row->{$1}/g; + (my $link = $alert_type->item_link) =~ s/{{(.*?)}}/$row->{$1}/g; + (my $desc = _($alert_type->item_description)) =~ s/{{(.*?)}}/$row->{$1}/g; + my $url = $c->uri_for( $link ); + my %item = ( + title => ent($title), + link => $url, + guid => $url, + description => ent(ent($desc)) # Yes, double-encoded, really. + ); + $item{pubDate} = $pubDate if $pubDate; + $item{category} = $row->{category} if $row->{category}; + + if ($c->cobrand->allow_photo_display && $row->{photo}) { + my $key = $alert_type->item_table eq 'comment' ? 'c' : 'id'; + $item{description} .= ent("\n<br><img src=\"". $c->cobrand->base_url . "/photo?$key=$row->{id}\">"); + } + my $recipient_name = $c->cobrand->contact_name; + $item{description} .= ent("\n<br><a href='$url'>" . + sprintf(_("Report on %s"), $recipient_name) . "</a>"); + + if ($row->{latitude} || $row->{longitude}) { + $item{georss} = { point => "$row->{latitude} $row->{longitude}" }; + } + + $c->stash->{rss}->add_item( %item ); +} + +sub add_parameters : Private { + my ( $self, $c ) = @_; + my $alert_type = $c->stash->{alert_type}; + + my $row = {}; + if ($alert_type->head_sql_query) { + my $q = $c->model('DB::Alert')->result_source->storage->dbh->prepare( + $alert_type->head_sql_query + ); + if ($alert_type->head_sql_query =~ /\?/) { + $q->execute(@{ $c->stash->{db_params} }); + } else { + $q->execute(); + } + $row = $q->fetchrow_hashref; + } + foreach ( keys %{ $c->stash->{title_params} } ) { + $row->{$_} = $c->stash->{title_params}->{$_}; + } + + (my $title = _($alert_type->head_title)) =~ s/{{(.*?)}}/$row->{$1}/g; + (my $link = $alert_type->head_link) =~ s/{{(.*?)}}/$row->{$1}/g; + (my $desc = _($alert_type->head_description)) =~ s/{{(.*?)}}/$row->{$1}/g; + + $c->stash->{rss}->channel( + title => ent($title), + link => $link . ($c->stash->{qs} || ''), + description => ent($desc), + language => 'en-gb', + ); +} + +sub local_problems_legacy : LocalRegex('^(\d+)[,/](\d+)(?:/(\d+))?$') { + my ( $self, $c ) = @_; + my ($x, $y, $d) = @{ $c->req->captures }; + $c->forward( 'get_query_parameters', [ $d ] ); + + # 5000/31 as initial scale factor for these RSS feeds, now variable so redirect. + my $e = int( ($x * 5000/31) + 0.5 ); + my $n = int( ($y * 5000/31) + 0.5 ); + $c->detach( 'redirect_lat_lon', [ $e, $n ] ); +} + +sub get_query_parameters : Private { + my ( $self, $c, $d ) = @_; + + $d = '' unless $d && $d =~ /^\d+$/; + $c->stash->{distance} = $d; + + my $state = $c->req->param('state') || 'all'; + $state = 'all' unless $state =~ /^(all|open|fixed)$/; + $c->stash->{state_qs} = "?state=$state" unless $state eq 'all'; + + $state = 'confirmed' if $state eq 'open'; + $c->stash->{state} = $state; +} + +sub redirect_lat_lon : Private { + my ( $self, $c, $e, $n ) = @_; + my ($lat, $lon) = Utils::convert_en_to_latlon_truncated($e, $n); + + my $d_str = ''; + $d_str = '/' . $c->stash->{distance} if $c->stash->{distance}; + my $state_qs = ''; + $state_qs = $c->stash->{state_qs} if $c->stash->{state_qs}; + $c->res->redirect( "/rss/l/$lat,$lon" . $d_str . $state_qs ); +} + +=head1 AUTHOR + +Matthew Somerville + +=head1 LICENSE + +Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. +Licensed under the Affero GPL. + +=cut + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Static.pm b/perllib/FixMyStreet/App/Controller/Static.pm new file mode 100755 index 000000000..2e6bda28c --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Static.pm @@ -0,0 +1,56 @@ +package FixMyStreet::App::Controller::Static; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::Static - Catalyst Controller + +=head1 DESCRIPTION + +Static pages Catalyst Controller. FAQ does some smarts to choose the correct +template depending on language, will need extending at some point. + +=head1 METHODS + +=cut + +sub about : Global : Args(0) { + my ( $self, $c ) = @_; + # don't need to do anything here - should just pass through. +} + +sub faq : Global : Args(0) { + my ( $self, $c ) = @_; + + # There should be a faq template for each language in a cobrand or default. + # This is because putting the FAQ translations into the PO files is + # overkill. + + # We rely on the list of languages for the site being restricted so that there + # will be a faq template for that language/cobrand combo. + + my $lang_code = $c->stash->{lang_code}; + my $template = "faq/faq-$lang_code.html"; + $c->stash->{template} = $template; +} + +sub fun : Global : Args(0) { + my ( $self, $c ) = @_; + # don't need to do anything here - should just pass through. +} + +sub posters : Global : Args(0) { + my ( $self, $c ) = @_; +} + +sub iphone : Global : Args(0) { + my ( $self, $c ) = @_; +} + +__PACKAGE__->meta->make_immutable; + +1; + diff --git a/perllib/FixMyStreet/App/Controller/Tokens.pm b/perllib/FixMyStreet/App/Controller/Tokens.pm new file mode 100644 index 000000000..9abef591d --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Tokens.pm @@ -0,0 +1,240 @@ +package FixMyStreet::App::Controller::Tokens; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::Tokens - Handle auth tokens + +=head1 DESCRIPTION + +Act on the various tokens that can be submitted. + +=head1 METHODS + +=cut + +=head2 confirm_problem + + /P/([0-9A-Za-z]{16,18}).*$ + +Confirm a problem - url appears in emails sent to users after they create the +problem but are not logged in. + +=cut + +sub confirm_problem : Path('/P') { + my ( $self, $c, $token_code ) = @_; + + my $auth_token = + $c->forward( 'load_auth_token', [ $token_code, 'problem' ] ); + + # Load the problem + my $data = $auth_token->data; + my $problem_id = $data->{id}; + my $problem = $c->cobrand->problems->find( { id => $problem_id } ) + || $c->detach('token_error'); + $c->stash->{problem} = $problem; + + # check that this email or domain are not the cause of abuse. If so hide it. + if ( $problem->is_from_abuser ) { + $problem->update( + { state => 'hidden', lastupdate => \'ms_current_timestamp()' } ); + $c->stash->{template} = 'tokens/abuse.html'; + return; + } + + # We have a problem - confirm it if needed! + $problem->update( + { + state => 'confirmed', + confirmed => \'ms_current_timestamp()', + lastupdate => \'ms_current_timestamp()', + } + ) if $problem->state eq 'unconfirmed'; + + # Subscribe problem reporter to email updates + $c->stash->{report} = $c->stash->{problem}; + $c->forward( '/report/new/create_reporter_alert' ); + + # log the problem creation user in to the site + if ( $data->{name} || $data->{password} ) { + $problem->user->name( $data->{name} ) if $data->{name}; + $problem->user->password( $data->{password}, 1 ) if $data->{password}; + $problem->user->update; + } + $c->authenticate( { email => $problem->user->email }, 'no_password' ); + $c->set_session_cookie_expire(0); + + return 1; +} + +=head2 redirect_to_partial_problem + + /P/... + +Redirect user to continue filling in a partial problem. The request is sent to +'/report/new' which might redirect again to '/around' if there is no location +found. + +=cut + +sub redirect_to_partial_problem : Path('/L') { + my ( $self, $c, $token_code ) = @_; + + my $url = $c->uri_for( "/report/new", { partial => $token_code } ); + return $c->res->redirect($url); +} + +=head2 confirm_alert + + /A/([0-9A-Za-z]{16,18}).*$ + +Confirm an alert - url appears in emails sent to users after they create the +alert but are not logged in. + +=cut + +sub confirm_alert : Path('/A') { + my ( $self, $c, $token_code ) = @_; + + my $auth_token = $c->forward( 'load_auth_token', [ $token_code, 'alert' ] ); + + # Load the problem + my $alert_id = $auth_token->data->{id}; + $c->stash->{confirm_type} = $auth_token->data->{type}; + my $alert = $c->model('DB::Alert')->find( { id => $alert_id } ) + || $c->detach('token_error'); + $c->stash->{alert} = $alert; + + # check that this email or domain are not the cause of abuse. If so hide it. + if ( $alert->is_from_abuser ) { + $c->stash->{template} = 'tokens/abuse.html'; + return; + } + + $c->authenticate( { email => $alert->user->email }, 'no_password' ); + $c->set_session_cookie_expire(0); + + $c->forward('/alert/confirm'); + + return 1; +} + +=head2 confirm_update + + /C/([0-9A-Za-z]{16,18}).*$ + +Confirm an update - url appears in emails sent to users after they create the +update but are not logged in. + +=cut + +sub confirm_update : Path('/C') { + my ( $self, $c, $token_code ) = @_; + + my $auth_token = + $c->forward( 'load_auth_token', [ $token_code, 'comment' ] ); + + # Load the problem + my $data = $auth_token->data; + my $comment_id = $data->{id}; + $c->stash->{add_alert} = $data->{add_alert}; + + my $comment = $c->model('DB::Comment')->find( { id => $comment_id } ) + || $c->detach('token_error'); + $c->stash->{update} = $comment; + + # check that this email or domain are not the cause of abuse. If so hide it. + if ( $comment->is_from_abuser ) { + $c->stash->{template} = 'tokens/abuse.html'; + return; + } + + if ( $data->{name} || $data->{password} ) { + $comment->user->name( $data->{name} ) if $data->{name}; + $comment->user->password( $data->{password}, 1 ) if $data->{password}; + $comment->user->update; + } + $c->authenticate( { email => $comment->user->email }, 'no_password' ); + $c->set_session_cookie_expire(0); + + $c->forward('/report/update/confirm'); + + return 1; +} + +sub load_questionnaire : Private { + my ( $self, $c, $token_code ) = @_; + + # Set up error handling + $c->stash->{error_template} = 'errors/generic.html'; + $c->stash->{message} = _("I'm afraid we couldn't validate that token. If you've copied the URL from an email, please check that you copied it exactly.\n"); + + my $auth_token = $c->forward( 'load_auth_token', [ $token_code, 'questionnaire' ] ); + $c->stash->{id} = $auth_token->data; + $c->stash->{token} = $token_code; + + my $questionnaire = $c->model('DB::Questionnaire')->find( + { id => $c->stash->{id} }, + { prefetch => 'problem' } + ); + $c->detach('/questionnaire/missing_problem') unless $questionnaire; + $c->stash->{questionnaire} = $questionnaire; +} + +sub questionnaire : Path('/Q') : Args(1) { + my ( $self, $c, $token_code ) = @_; + $c->forward( 'load_questionnaire', [ $token_code ] ); + + $c->authenticate( { email => $c->stash->{questionnaire}->problem->user->email }, 'no_password' ); + $c->set_session_cookie_expire(0); + $c->forward( '/questionnaire/index'); +} + +=head2 load_auth_token + + my $auth_token = + $c->forward( 'load_auth_token', [ $token_code, $token_scope ] ); + + +Load the token if possible. If token is not found, or not valid detach to a nice +error message. + +=cut + +sub load_auth_token : Private { + my ( $self, $c, $token_code, $scope ) = @_; + + # clean the token of bad chars (in case of email client issues) + $token_code ||= ''; + $token_code =~ s{[^a-zA-Z0-9]+}{}g; + + # try to load the token + my $token = $c->model('DB::Token')->find( + { + scope => $scope, + token => $token_code, + } + ) || $c->detach('token_error'); + + return $token; +} + +=head2 token_error + +Display an error page saying that there is something wrong with the token. + +=cut + +sub token_error : Private { + my ( $self, $c ) = @_; + $c->stash->{template} = $c->stash->{error_template} || 'tokens/error.html'; + $c->detach; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Model/DB.pm b/perllib/FixMyStreet/App/Model/DB.pm new file mode 100644 index 000000000..f9e43172f --- /dev/null +++ b/perllib/FixMyStreet/App/Model/DB.pm @@ -0,0 +1,24 @@ +package FixMyStreet::App::Model::DB; +use base 'Catalyst::Model::DBIC::Schema'; + +use strict; +use warnings; + +use FixMyStreet; + +__PACKAGE__->config( + schema_class => 'FixMyStreet::DB', + connect_info => FixMyStreet->dbic_connect_info, +); + +=head1 NAME + +FixMyStreet::App::Model::DB - Catalyst DBIC Schema Model + +=head1 DESCRIPTION + +L<Catalyst::Model::DBIC::Schema> Model using schema L<FixMyStreet::DB> + +=cut + +1; diff --git a/perllib/FixMyStreet/App/Model/EmailSend.pm b/perllib/FixMyStreet/App/Model/EmailSend.pm new file mode 100644 index 000000000..73086c65f --- /dev/null +++ b/perllib/FixMyStreet/App/Model/EmailSend.pm @@ -0,0 +1,51 @@ +package FixMyStreet::App::Model::EmailSend; +use base 'Catalyst::Model::Adaptor'; + +use strict; +use warnings; + +use FixMyStreet; +use Email::Send; + +=head1 NAME + +FixMyStreet::App::Model::EmailSend + +=head1 DESCRIPTION + +Thin wrapper around Email::Send - configuring it correctly acording to our config. + +If the config value 'SMTP_SMARTHOST' is set then email is routed via SMTP to +that. Otherwise it is sent using a 'sendmail' like binary on the local system. + +And finally if if FixMyStreet->test_mode returns true then emails are not sent +at all but are stored in memory for the test suite to inspect (using +Email::Send::Test). + +=cut + +my $args = undef; + +if ( FixMyStreet->test_mode ) { + + # Email::Send::Test + $args = { mailer => 'Test', }; +} +elsif ( my $smtp_host = FixMyStreet->config('SMTP_SMARTHOST') ) { + + # Email::Send::SMTP + $args = { + mailer => 'SMTP', + mailer_args => [ Host => $smtp_host ], + }; +} +else { + + # Email::Send::Sendmail + $args = { mailer => 'Sendmail' }; +} + +__PACKAGE__->config( + class => 'Email::Send', + args => $args, +); diff --git a/perllib/FixMyStreet/App/View/Email.pm b/perllib/FixMyStreet/App/View/Email.pm new file mode 100644 index 000000000..86d5c1d60 --- /dev/null +++ b/perllib/FixMyStreet/App/View/Email.pm @@ -0,0 +1,44 @@ +package FixMyStreet::App::View::Email; +use base 'Catalyst::View::TT'; + +use strict; +use warnings; + +use mySociety::Locale; +use FixMyStreet; + +__PACKAGE__->config( + TEMPLATE_EXTENSION => '.txt', + INCLUDE_PATH => [ # + FixMyStreet->path_to( 'templates', 'email', 'default' ), + ], + ENCODING => 'utf8', + render_die => 1, + expose_methods => ['loc'], +); + +=head1 NAME + +FixMyStreet::App::View::Email - TT View for FixMyStreet::App + +=head1 DESCRIPTION + +TT View for FixMyStreet::App. + +=cut + +=head2 loc + + [% loc('Some text to localize') %] + +Passes the text to the localisation engine for translations. + +=cut + +sub loc { + my ( $self, $c, @args ) = @_; + return _(@args); +} + +1; + diff --git a/perllib/FixMyStreet/App/View/Web.pm b/perllib/FixMyStreet/App/View/Web.pm new file mode 100644 index 000000000..df2d0ac20 --- /dev/null +++ b/perllib/FixMyStreet/App/View/Web.pm @@ -0,0 +1,146 @@ +package FixMyStreet::App::View::Web; +use base 'Catalyst::View::TT'; + +use strict; +use warnings; + +use mySociety::Locale; +use mySociety::Web qw(ent); +use FixMyStreet; +use CrossSell; +use Utils; + +__PACKAGE__->config( + TEMPLATE_EXTENSION => '.html', + INCLUDE_PATH => [ # + FixMyStreet->path_to( 'templates', 'web', 'default' ), + ], + ENCODING => 'utf8', + render_die => 1, + expose_methods => [ + 'loc', 'nget', 'tprintf', 'display_crosssell_advert', 'prettify_epoch', + 'add_links', + ], + FILTERS => { + escape_js => \&escape_js, + }, +); + +=head1 NAME + +FixMyStreet::App::View::Web - TT View for FixMyStreet::App + +=head1 DESCRIPTION + +TT View for FixMyStreet::App. + +=cut + +=head2 loc + + [% loc('Some text to localize') %] + +Passes the text to the localisation engine for translations. + +=cut + +sub loc { + my ( $self, $c, @args ) = @_; + return _(@args); +} + +=head2 nget + + [% nget( 'singular', 'plural', $number ) %] + +Use first or second srting depending on the number. + +=cut + +sub nget { + my ( $self, $c, @args ) = @_; + return mySociety::Locale::nget(@args); +} + +=head2 tprintf + + [% tprintf( 'foo %s bar', 'insert' ) %] + +sprintf (different name to avoid clash) + +=cut + +sub tprintf { + my ( $self, $c, $format, @args ) = @_; + return sprintf $format, @args; +} + +=head2 display_crosssell_advert + + [% display_crosssell_advert( email, name ) %] + +Displays a crosssell advert if permitted by the cobrand. + +=cut + +sub display_crosssell_advert { + my ( $self, $c, $email, $name, %data ) = @_; + + return unless $c->cobrand->allow_crosssell_adverts(); + return CrossSell::display_advert( $c, $email, $name, %data ); +} + +=head2 Utils::prettify_epoch + + [% pretty = prettify_epoch( $epoch, $short_bool ) %] + +Return a pretty version of the epoch. + + $short_bool = 1; # 16:02, 29 Mar 2011 + $short_bool = 0; # 16:02, Tuesday 29 March 2011 + +=cut + +sub prettify_epoch { + my ( $self, $c, $epoch, $short_bool ) = @_; + return Utils::prettify_epoch( $epoch, $short_bool ); +} + +=head2 add_links + + [% add_links( text ) | html_para %] + +Add some links to some text (and thus HTML-escapes the other text. + +=cut + +sub add_links { + my ( $self, $c, $text ) = @_; + + $text =~ s/\r//g; + $text = ent($text); + $text =~ s{(https?://[^\s]+)}{<a href="$1">$1</a>}g; + return $text; +} + +=head2 escape_js + +Used to escape strings that are going to be put inside JavaScript. + +=cut + +sub escape_js { + my $text = shift; + my %lookup = ( + '\\' => 'u005c', + '"' => 'u0022', + "'" => 'u0027', + '<' => 'u003c', + '>' => 'u003e', + ); + $text =~ s/([\\"'<>])/\\$lookup{$1}/g; + return $text; +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand.pm b/perllib/FixMyStreet/Cobrand.pm new file mode 100644 index 000000000..6fe2a2bc8 --- /dev/null +++ b/perllib/FixMyStreet/Cobrand.pm @@ -0,0 +1,91 @@ +# Copyright (c) 2009 UK Citizens Online Democracy. All rights reserved. +# Email: evdb@mysociety.org. WWW: http://www.mysociety.org + +package FixMyStreet::Cobrand; + +use strict; +use warnings; + +use FixMyStreet; +use Carp; + +use Module::Pluggable + sub_name => '_cobrands', + search_path => ['FixMyStreet::Cobrand'], + require => 1; + +my @ALL_COBRAND_CLASSES = __PACKAGE__->_cobrands; + +=head2 get_allowed_cobrands + +Return an array reference of allowed cobrand subdomains + +=cut + +sub get_allowed_cobrands { + my $allowed_cobrand_string = FixMyStreet->config('ALLOWED_COBRANDS'); + my @allowed_cobrands = split( /\|/, $allowed_cobrand_string ); + return \@allowed_cobrands; +} + +=head2 available_cobrand_classes + + @available_cobrand_classes = + FixMyStreet::Cobrand->available_cobrand_classes(); + +Return an array of all the classes that were found and that have monikers that +match the values from get_allowed_cobrands. + +=cut + +sub available_cobrand_classes { + my $class = shift; + + my %allowed = map { $_ => 1 } @{ $class->get_allowed_cobrands }; + my @avail = grep { $allowed{ $_->moniker } } @ALL_COBRAND_CLASSES; + + return @avail; +} + +=head2 get_class_for_host + + $cobrand_class = FixMyStreet::Cobrand->get_class_for_host( $host ); + +Given a host determine which cobrand we should be using. + +=cut + +sub get_class_for_host { + my $class = shift; + my $host = shift; + + foreach my $avail ( $class->available_cobrand_classes ) { + my $moniker = $avail->moniker; + return $avail if $host =~ m{$moniker}; + } + + # if none match then use the default + return 'FixMyStreet::Cobrand::Default'; +} + +=head2 get_class_for_moniker + + $cobrand_class = FixMyStreet::Cobrand->get_class_for_moniker( $moniker ); + +Given a moniker determine which cobrand we should be using. + +=cut + +sub get_class_for_moniker { + my $class = shift; + my $moniker = shift; + + foreach my $avail ( $class->available_cobrand_classes ) { + return $avail if $moniker eq $avail->moniker; + } + + # if none match then use the default + return 'FixMyStreet::Cobrand::Default'; +} + +1; diff --git a/perllib/FixMyStreet/Cobrand/Barnet.pm b/perllib/FixMyStreet/Cobrand/Barnet.pm new file mode 100644 index 000000000..a12fa6d06 --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/Barnet.pm @@ -0,0 +1,80 @@ +package FixMyStreet::Cobrand::Barnet; +use base 'FixMyStreet::Cobrand::Default'; + +use strict; +use warnings; + +use Carp; +use URI::Escape; +use mySociety::VotingArea; + +sub site_restriction { + return ( "and council='2489'", 'barnet', { council => '2489' } ); +} + +sub problems_clause { + return { council => '2489' }; +} + +sub problems { + my $self = shift; + return $self->{c}->model('DB::Problem')->search( $self->problems_clause ); +} + +sub base_url { + my $base_url = mySociety::Config::get('BASE_URL'); + if ( $base_url !~ /barnet/ ) { + $base_url =~ s{http://(?!www\.)}{http://barnet.}g; + $base_url =~ s{http://www\.}{http://barnet.}g; + } + return $base_url; +} + +sub site_title { + my ($self) = @_; + return 'Barnet Council FixMyStreet'; +} + +sub enter_postcode_text { + my ($self) = @_; + return 'Enter a Barnet postcode, or street name and area'; +} + +sub council_check { + my ( $self, $params, $context ) = @_; + + my $councils = $params->{all_councils}; + my $council_match = defined $councils->{2489}; + if ($council_match) { + return 1; + } + my $url = 'http://www.fixmystreet.com/'; + $url .= 'alert' if $context eq 'alert'; + $url .= '?pc=' . URI::Escape::uri_escape( $self->{c}->req->param('pc') ) + if $self->{c}->req->param('pc'); + my $error_msg = "That location is not covered by Barnet. +Please visit <a href=\"$url\">the main FixMyStreet site</a>."; + return ( 0, $error_msg ); +} + +# All reports page only has the one council. +sub all_councils_report { + return 0; +} + +sub disambiguate_location { + return { + centre => '51.612832,-0.218169', + span => '0.0563,0.09', + bounds => [ '51.584682,-0.263169', '51.640982,-0.173169' ], + }; +} + +sub recent_photos { + my ( $self, $num, $lat, $lon, $dist ) = @_; + $num = 2 if $num == 3; + return $self->problems->recent_photos( $num, $lat, $lon, $dist ); +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand/Default.pm b/perllib/FixMyStreet/Cobrand/Default.pm new file mode 100644 index 000000000..134111076 --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/Default.pm @@ -0,0 +1,936 @@ +package FixMyStreet::Cobrand::Default; + +use strict; +use warnings; +use FixMyStreet; +use URI; + +use Carp; +use mySociety::MaPit; +use mySociety::PostcodeUtil; + +=head2 new + + my $cobrand = $class->new; + my $cobrand = $class->new( { c => $c } ); + +Create a new cobrand object, optionally setting the context. + +You probably shouldn't need to do this and should get the cobrand object via a +method in L<FixMyStreet::Cobrand> instead. + +=cut + +sub new { + my $class = shift; + my $self = shift || {}; + return bless $self, $class; +} + +=head2 moniker + + $moniker = $cobrand_class->moniker(); + +Returns a moniker that can be used to identify this cobrand. By default this is +the last part of the class name lowercased - eg 'F::C::SomeCobrand' becomes +'somecobrand'. + +=cut + +sub moniker { + my $class = ref( $_[0] ) || $_[0]; # deal with object or class + my ($last_part) = $class =~ m{::(\w+)$}; + $last_part = lc($last_part); + return '' if $last_part eq 'default'; + return $last_part; +} + +=head2 is_default + + $bool = $cobrand->is_default(); + +Returns true if this is the default cobrand, false otherwise. + +=cut + +sub is_default { + my $self = shift; + return $self->moniker eq ''; +} + +=head2 path_to_web_templates + + $path = $cobrand->path_to_web_templates( ); + +Returns the path to the templates for this cobrand - by default +"templates/web/$moniker" + +=cut + +sub path_to_web_templates { + my $self = shift; + return FixMyStreet->path_to( 'templates/web', $self->moniker ); +} + +=head1 country + +Returns the country that this cobrand operates in, as an ISO3166-alpha2 code. + +=cut + +sub country { + return 'GB'; +} + +=head1 problems_clause + +Returns a hash for a query to be used by problems (and elsewhere in joined +queries) to restrict results for a cobrand. + +=cut + +sub problems_clause {} + +=head1 problems + +Returns a ResultSet of Problems, restricted to a subset if we're on a cobrand +that only wants some of the data. + +=cut + +sub problems { + my $self = shift; + return $self->{c}->model('DB::Problem'); +} + +=head1 site_restriction + +Return a site restriction clause and a site key if the cobrand uses a subset of +the FixMyStreet data. Parameter is any extra data the cobrand needs. Returns an +empty string and site key 0 if the cobrand uses all the data. + +=cut + +sub site_restriction { return ( "", 0, {} ) } + +=head2 contact_restriction + +Return a contact restriction clause if the cobrand uses a subset of the +FixMyStreet contact data. + +=cut + +sub contact_restriction { + {}; +} + +=head2 restriction + +Return a restriction to pull out data saved while using the cobrand site. + +=cut + +sub restriction { + my $self = shift; + + return $self->moniker ? { cobrand => $self->moniker } : {}; +} + +=head2 base_url_for_emails + +Return the base url to use in links in emails for the cobranded version of the +site, parameter is extra data. + +=cut + +sub base_url_for_emails { + my $self = shift; + return $self->base_url; +} + +=head2 base_url_with_lang + +=cut + +sub base_url_with_lang { + my $self = shift; + my $email = shift; + + if ($email) { + return $self->base_url_for_emails; + } else { + return $self->base_url; + } +} + +=head2 admin_base_url + +Base URL for the admin interface. + +=cut + +sub admin_base_url { 0 } + +=head2 writetothem_url + +URL for writetothem; parameter is COBRAND_DATA. + +=cut + +sub writetothem_url { 0 } + +=head2 base_url + +Return the base url for the cobranded version of the site + +=cut + +sub base_url { mySociety::Config::get('BASE_URL') } + +=head2 base_host + +Return the base host for the cobranded version of the site + +=cut + +sub base_host { + my $self = shift; + my $uri = URI->new( $self->base_url ); + return $uri->host; +} + +=head2 enter_postcode_text + +Return the text that prompts the user to enter their postcode/place name. +Parameter is QUERY + +=cut + +sub enter_postcode_text { '' } + +=head2 set_lang_and_domain + + my $set_lang = $cobrand->set_lang_and_domain( $lang, $unicode, $dir ) + +Set the language and domain of the site based on the cobrand and host. + +=cut + +sub set_lang_and_domain { + my ( $self, $lang, $unicode, $dir ) = @_; + my $set_lang = mySociety::Locale::negotiate_language( + 'en-gb,English,en_GB', $lang + ); + mySociety::Locale::gettext_domain( 'FixMyStreet', $unicode, $dir ); + mySociety::Locale::change(); + return $set_lang; +} + +=head2 alert_list_options + +Return HTML for a list of alert options for the cobrand, given QUERY and +OPTIONS. + +=cut + +sub alert_list_options { 0 } + +=head2 recent_photos + +Return N recent photos. If EASTING, NORTHING and DISTANCE are supplied, the +photos must be attached to problems within DISTANCE of the point defined by +EASTING and NORTHING. + +=cut + +sub recent_photos { + my $self = shift; + return $self->problems->recent_photos(@_); +} + +=head2 recent + +Return recent problems on the site. + +=cut + +sub recent { + my ( $self ) = @_; + return $self->problems->recent(); +} + +=item shorten_recency_if_new_greater_than_fixed + +By default we want to shorten the recency so that the numbers are more +attractive. + +=cut + +sub shorten_recency_if_new_greater_than_fixed { + return 1; +} + +=head2 front_stats_data + +Return a data structure containing the front stats information that a template +can then format. + +=cut + +sub front_stats_data { + my ( $self ) = @_; + + my $recency = '1 week'; + my $shorter_recency = '3 days'; + + my $fixed = $self->problems->recent_fixed(); + my $updates = $self->problems->number_comments(); + my $new = $self->problems->recent_new( $recency ); + + if ( $new > $fixed && $self->shorten_recency_if_new_greater_than_fixed ) { + $recency = $shorter_recency; + $new = $self->problems->recent_new( $recency ); + } + + my $stats = { + fixed => $fixed, + updates => $updates, + new => $new, + recency => $recency, + }; + + return $stats; +} + +=head2 disambiguate_location + +Returns disambiguating information available + +=cut + +sub disambiguate_location { + return { + country => 'uk', + }; +} + +=head2 form_elements + +Parameters are FORM_NAME, QUERY. Return HTML for any extra needed elements for +FORM_NAME + +=cut + +sub form_elements { '' } + +=head2 cobrand_data_for_generic_update + +Parameter is UPDATE_DATA, a reference to a hash of non-cobranded update data. +Return cobrand extra data for the update + +=cut + +sub cobrand_data_for_generic_update { '' } + +=head2 cobrand_data_for_generic_update + +Parameter is PROBLEM_DATA, a reference to a hash of non-cobranded problem data. +Return cobrand extra data for the problem + +=cut + +sub cobrand_data_for_generic_problem { '' } + +=head2 extra_problem_data + +Parameter is QUERY. Return a string of extra data to be stored with a problem + +=cut + +sub extra_problem_data { '' } + +=head2 extra_update_data + +Parameter is QUERY. Return a string of extra data to be stored with an update + +=cut + +sub extra_update_data { '' } + +=head2 extra_alert_data + +Parameter is QUERY. Return a string of extra data to be stored with an alert + +=cut + +sub extra_alert_data { '' } + +=head2 extra_data + +Given a QUERY, extract any extra data required by the cobrand + +=cut + +sub extra_data { '' } + +=head2 extra_problem_meta_text + +Returns any extra text to be displayed with a PROBLEM. + +=cut + +sub extra_problem_meta_text { '' } + +=head2 extra_update_meta_text + +Returns any extra text to be displayed with an UPDATE. + +=cut + +sub extra_update_meta_text { '' } + +=head2 uri + +Given a URL ($_[1]), QUERY, EXTRA_DATA, return a URL with any extra params +needed appended to it. + +In the default case, if we're using an OpenLayers map, we need to make +sure zoom is always present if lat/lon are, to stop OpenLayers defaulting +to null/0. + +=cut + +sub uri { + my ( $self, $uri ) = @_; + + (my $map_class = $FixMyStreet::Map::map_class) =~ s/^FixMyStreet::Map:://; + return $uri unless $map_class =~ /OSM|FMS/; + + $uri->query_param( zoom => 3 ) + if $uri->query_param('lat') && !$uri->query_param('zoom'); + + return $uri; +} + + +=head2 header_params + +Return any params to be added to responses + +=cut + +sub header_params { return {} } + +=head2 root_path_js + +Parameter is QUERY. Return some js to set the root path from which AJAX queries +should be made. + +=cut + +sub root_path_js { 'var root_path = "";' } + +=head2 site_title + +Return the title to be used in page heads. + +=cut + +sub site_title { 'FixMyStreet' } + +=head2 on_map_list_limit + +Return the maximum number of items to be given in the list of reports on the map + +=cut + +sub on_map_list_limit { return undef; } + +=head2 on_map_default_max_pin_age + +Return the default maximum age for pins. + +=cut + +sub on_map_default_max_pin_age { return '6 months'; } + +=head2 allow_photo_upload + +Return a boolean indicating whether the cobrand allows photo uploads + +=cut + +sub allow_photo_upload { return 1; } + +=head2 allow_crosssell_adverts + +Return a boolean indicating whether the cobrand allows the display of crosssell +adverts + +=cut + +sub allow_crosssell_adverts { return 1; } + +=head2 allow_photo_display + +Return a boolean indicating whether the cobrand allows photo display + +=cut + +sub allow_photo_display { return 1; } + +=head2 allow_update_reporting + +Return a boolean indication whether users should see links next to updates +allowing them to report them as offensive. + +=cut + +sub allow_update_reporting { return 0; } + +=head2 geocode_postcode + +Given a QUERY, return LAT/LON and/or ERROR. + +=cut + +sub geocode_postcode { + my ( $self, $s ) = @_; + + if ($s =~ /^\d+$/) { + return { + error => 'FixMyStreet is a UK-based website that currently works in England, Scotland, and Wales. Please enter either a postcode, or a Great British street name and area.' + }; + } elsif (mySociety::PostcodeUtil::is_valid_postcode($s)) { + my $location = mySociety::MaPit::call('postcode', $s); + if ($location->{error}) { + return { + error => $location->{code} =~ /^4/ + ? _('That postcode was not recognised, sorry.') + : $location->{error} + }; + } + my $island = $location->{coordsyst}; + if (!$island) { + return { + error => _("Sorry, that appears to be a Crown dependency postcode, which we don't cover.") + }; + } elsif ($island eq 'I') { + return { + error => _("We do not currently cover Northern Ireland, I'm afraid.") + }; + } + return { + latitude => $location->{wgs84_lat}, + longitude => $location->{wgs84_lon}, + }; + } + return {}; +} + +=head2 geocoded_string_check + +Parameters are LOCATION, QUERY. Return a boolean indicating whether the +string LOCATION passes the cobrands checks. + +=cut + +sub geocoded_string_check { return 1; } + +=head2 find_closest + +Used by send-reports to attach nearest things to the bottom of the report + +=cut + +sub find_closest { + my ( $self, $latitude, $longitude ) = @_; + my $str = ''; + + # Get nearest road-type thing from Bing + my $key = mySociety::Config::get('BING_MAPS_API_KEY', ''); + if ($key) { + my $url = "http://dev.virtualearth.net/REST/v1/Locations/$latitude,$longitude?c=en-GB&key=$key"; + my $j = LWP::Simple::get($url); + if ($j) { + $j = JSON->new->utf8->allow_nonref->decode($j); + if ($j->{resourceSets}[0]{resources}[0]{name}) { + $str .= sprintf(_("Nearest road to the pin placed on the map (automatically generated by Bing Maps): %s"), + $j->{resourceSets}[0]{resources}[0]{name}) . "\n\n"; + } + } + } + + # Get nearest postcode from Matthew's random gazetteer (put in MaPit? Or elsewhere?) + my $url = "http://gazetteer.dracos.vm.bytemark.co.uk/point/$latitude,$longitude.json"; + my $j = LWP::Simple::get($url); + if ($j) { + $j = JSON->new->utf8->allow_nonref->decode($j); + if ($j->{postcode}) { + $str .= sprintf(_("Nearest postcode to the pin placed on the map (automatically generated): %s (%sm away)"), + $j->{postcode}[0], $j->{postcode}[1]) . "\n\n"; + } + } + + return $str; +} + +=head2 council_check + +Paramters are COUNCILS, QUERY, CONTEXT. Return a boolean indicating whether +COUNCILS pass any extra checks. CONTEXT is where we are on the site. + +=cut + +sub council_check { return ( 1, '' ); } + +=head2 feed_xsl + +Return an XSL to be used in rendering feeds + +=cut + +sub feed_xsl { '/xsl.xsl' } + +=head2 all_councils_report + +Return a boolean indicating whether the cobrand displays a report of all +councils + +=cut + +sub all_councils_report { 1 } + +=head2 ask_ever_reported + +Return a boolean indicating whether people should be asked whether this is the +first time they' ve reported a problem + +=cut + +sub ask_ever_reported { 1 } + +=head2 admin_pages + +List of names of pages to display on the admin interface + +=cut + +sub admin_pages { 0 } + +=head2 admin_show_creation_graph + +Show the problem creation graph in the admin interface +=cut + +sub admin_show_creation_graph { 1 } + +=head2 area_types, area_min_generation + +The MaPit types this site handles + +=cut + +sub area_types { return qw(DIS LBO MTD UTA CTY COI); } +sub area_min_generation { 10 } + +=head2 contact_name, contact_email + +Return the contact name or email for the cobranded version of the site (to be +used in emails). + +=cut + +sub contact_name { $_[0]->get_cobrand_conf('CONTACT_NAME') } +sub contact_email { $_[0]->get_cobrand_conf('CONTACT_EMAIL') } + +=head2 get_cobrand_conf COBRAND KEY + +Get the value for KEY from the config file for COBRAND + +=cut + +sub get_cobrand_conf { + my ( $self, $key ) = @_; + my $value = undef; + my $cobrand_moniker = $self->moniker; + + my $cobrand_config_file = + FixMyStreet->path_to("conf/cobrands/$cobrand_moniker/general"); + my $normal_config_file = FixMyStreet->path_to('conf/general'); + + if ( -e $cobrand_config_file ) { + + # FIXME - don't rely on the config file name - should + # change mySociety::Config so that it can return values from a + # particular config file instead + mySociety::Config::set_file("$cobrand_config_file"); + my $config_key = $key . "_" . uc($cobrand_moniker); + $value = mySociety::Config::get( $config_key, undef ); + mySociety::Config::set_file("$normal_config_file"); + } + + # If we didn't find a value use one from normal config + if ( !defined($value) ) { + $value = mySociety::Config::get($key); + } + + return $value; +} + +=item email_host + +Return if we are the virtual host that sends email for this cobrand + +=cut + +sub email_host { + return 1; +} + +=item remove_redundant_councils + +Remove councils whose reports go to another council + +=cut + +sub remove_redundant_councils { + my $self = shift; + my $all_councils = shift; + + # Ipswich & St Edmundsbury are responsible for everything in their + # areas, not Suffolk + delete $all_councils->{2241} + if $all_councils->{2446} # + || $all_councils->{2443}; + + # Norwich is responsible for everything in its areas, not Norfolk + delete $all_councils->{2233} # + if $all_councils->{2391}; +} + +=item filter_all_council_ids_list + +Removes any council IDs that we don't need from an array and returns the +filtered array + +=cut + +sub filter_all_council_ids_list { + my $self = shift; + return @_; +} + +=item short_name + +Remove extra information from council names for tidy URIs + +=cut + +sub short_name { + my $self = shift; + my ($area, $info) = @_; + # Special case Durham as it's the only place with two councils of the same name + return 'Durham+County' if $area->{name} eq 'Durham County Council'; + return 'Durham+City' if $area->{name} eq 'Durham City Council'; + + my $name = $area->{name}; + $name =~ s/ (Borough|City|District|County) Council$//; + $name =~ s/ Council$//; + $name =~ s/ & / and /; + $name =~ s{/}{_}g; + $name = URI::Escape::uri_escape_utf8($name); + $name =~ s/%20/+/g; + return $name; + +} + +=item council_rss_alert_options + +Generate a set of options for council rss alerts. + +=cut + +sub council_rss_alert_options { + my $self = shift; + my $all_councils = shift; + my $c = shift; + + my %councils = map { $_ => 1 } $self->area_types(); + + my $num_councils = scalar keys %$all_councils; + + my ( @options, @reported_to_options ); + if ( $num_councils == 1 or $num_councils == 2 ) { + my ($council, $ward); + foreach (values %$all_councils) { + if ($councils{$_->{type}}) { + $council = $_; + $council->{short_name} = $self->short_name( $council ); + ( $council->{id_name} = $council->{short_name} ) =~ tr/+/_/; + } else { + $ward = $_; + $ward->{short_name} = $self->short_name( $ward ); + ( $ward->{id_name} = $ward->{short_name} ) =~ tr/+/_/; + } + } + + push @options, + { + type => 'council', + id => sprintf( 'council:%s:%s', $council->{id}, $council->{id_name} ), + text => sprintf( _('Problems within %s'), $council->{name}), + rss_text => sprintf( _('RSS feed of problems within %s'), $council->{name}), + uri => $c->uri_for( '/rss/reports/' . $council->{short_name} ), + }; + push @options, + { + type => 'ward', + id => sprintf( 'ward:%s:%s:%s:%s', $council->{id}, $ward->{id}, $council->{id_name}, $ward->{id_name} ), + rss_text => sprintf( _('RSS feed of problems within %s ward'), $ward->{name}), + text => sprintf( _('Problems within %s ward'), $ward->{name}), + uri => $c->uri_for( '/rss/reports/' . $council->{short_name} . '/' . $ward->{short_name} ), + } if $ward; + } elsif ( $num_councils == 4 ) { +# # Two-tier council + my ($county, $district, $c_ward, $d_ward); + foreach (values %$all_councils) { + $_->{short_name} = $self->short_name( $_ ); + ( $_->{id_name} = $_->{short_name} ) =~ tr/+/_/; + if ($_->{type} eq 'CTY') { + $county = $_; + } elsif ($_->{type} eq 'DIS') { + $district = $_; + } elsif ($_->{type} eq 'CED') { + $c_ward = $_; + } elsif ($_->{type} eq 'DIW') { + $d_ward = $_; + } + } + my $district_name = $district->{name}; + my $d_ward_name = $d_ward->{name}; + my $county_name = $county->{name}; + my $c_ward_name = $c_ward->{name}; + + push @options, + { + type => 'area', + id => sprintf( 'area:%s:%s', $district->{id}, $district->{id_name} ), + text => $district_name, + rss_text => sprintf( _('RSS feed for %s'), $district_name ), + uri => $c->uri_for( '/rss/areas/' . $district->{short_name} ) + }, + { + type => 'area', + id => sprintf( 'area:%s:%s:%s:%s', $district->{id}, $d_ward->{id}, $district->{id_name}, $d_ward->{id_name} ), + text => sprintf( _('%s ward, %s'), $d_ward_name, $district_name ), + rss_text => sprintf( _('RSS feed for %s ward, %s'), $d_ward_name, $district_name ), + uri => $c->uri_for( '/rss/areas/' . $district->{short_name} . '/' . $d_ward->{short_name} ) + }, + { + type => 'area', + id => sprintf( 'area:%s:%s', $county->{id}, $county->{id_name} ), + text => $county_name, + rss_text => sprintf( _('RSS feed for %s'), $county_name ), + uri => $c->uri_for( '/rss/areas/' . $county->{short_name} ) + }, + { + type => 'area', + id => sprintf( 'area:%s:%s:%s:%s', $county->{id}, $c_ward->{id}, $county->{id_name}, $c_ward->{id_name} ), + text => sprintf( _('%s ward, %s'), $c_ward_name, $county_name ), + rss_text => sprintf( _('RSS feed for %s ward, %s'), $c_ward_name, $county_name ), + uri => $c->uri_for( '/rss/areas/' . $county->{short_name} . '/' . $c_ward->{short_name} ) + }; + + push @reported_to_options, + { + type => 'council', + id => sprintf( 'council:%s:%s', $district->{id}, $district->{id_name} ), + text => $district->{name}, + rss_text => sprintf( _('RSS feed of %s'), $district->{name}), + uri => $c->uri_for( '/rss/reports/' . $district->{short_name} ), + }, + { + type => 'ward', + id => sprintf( 'ward:%s:%s:%s:%s', $district->{id}, $d_ward->{id}, $district->{id_name}, $d_ward->{id_name} ), + rss_text => sprintf( _('RSS feed of %s, within %s ward'), $district->{name}, $d_ward->{name}), + text => sprintf( _('%s, within %s ward'), $district->{name}, $d_ward->{name}), + uri => $c->uri_for( '/rss/reports/' . $district->{short_name} . '/' . $d_ward->{short_name} ), + }, + { + type => 'council', + id => sprintf( 'council:%s:%s', $county->{id}, $county->{id_name} ), + text => $county->{name}, + rss_text => sprintf( _('RSS feed of %s'), $county->{name}), + uri => $c->uri_for( '/rss/reports/' . $county->{short_name} ), + }, + { + type => 'ward', + id => sprintf( 'ward:%s:%s:%s:%s', $county->{id}, $c_ward->{id}, $county->{id_name}, $c_ward->{id_name} ), + rss_text => sprintf( _('RSS feed of %s, within %s ward'), $county->{name}, $c_ward->{name}), + text => sprintf( _('%s, within %s ward'), $county->{name}, $c_ward->{name}), + uri => $c->uri_for( '/rss/reports/' . $county->{short_name} . '/' . $c_ward->{short_name} ), + }; + + + } else { + throw Error::Simple('An area with three tiers of council? Impossible! '. join('|',keys %$all_councils)); + } + + return ( \@options, @reported_to_options ? \@reported_to_options : undef ); +} + +=head2 generate_problem_banner + + my $banner = $c->cobrand->generate_problem_banner; + + <p id="[% banner.id %]:>[% banner.text %]</p> + +Generate id and text for banner that appears at top of problem page. + +=cut + +sub generate_problem_banner { + my ( $self, $problem ) = @_; + + my $banner = {}; + if ($problem->state eq 'confirmed' && time() - $problem->lastupdate_local->epoch > 8*7*24*60*60) { + $banner->{id} = 'unknown'; + $banner->{text} = _('This problem is old and of unknown status.'); + } + if ($problem->state eq 'fixed') { + $banner->{id} = 'fixed'; + $banner->{text} = _('This problem has been fixed') . '.'; + } + + return $banner; +} + +sub reports_council_check { + my ( $self, $c, $code ) = @_; + + if ($code =~ /^(\d\d)([a-z]{2})?([a-z]{2})?$/i) { + my $area = mySociety::MaPit::call( 'area', uc $code ); + $c->detach( 'redirect_index' ) if $area->{error}; # Given a bad/old ONS code + if (length($code) == 6) { + my $council = mySociety::MaPit::call( 'area', $area->{parent_area} ); + $c->stash->{ward} = $area; + $c->stash->{council} = $council; + } else { + $c->stash->{council} = $area; + } + $c->detach( 'redirect_area' ); + } +} + +=head2 default_photo_resize + +Size that photos are to be resized to for display. If photos aren't +to be resized then return 0; + +=cut + +sub default_photo_resize { return 0; } + +1; + diff --git a/perllib/FixMyStreet/Cobrand/EmptyHomes.pm b/perllib/FixMyStreet/Cobrand/EmptyHomes.pm new file mode 100644 index 000000000..eda0b2882 --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/EmptyHomes.pm @@ -0,0 +1,178 @@ +package FixMyStreet::Cobrand::EmptyHomes; +use base 'FixMyStreet::Cobrand::Default'; + +use strict; +use warnings; + +use FixMyStreet; +use mySociety::Locale; +use Carp; + +=item + +Return the base url for this cobranded site + +=cut + +sub base_url { + my $base_url = FixMyStreet->config('BASE_URL'); + if ( $base_url !~ /emptyhomes/ ) { + $base_url =~ s/http:\/\//http:\/\/emptyhomes\./g; + } + return $base_url; +} + +sub admin_base_url { + return 'https://secure.mysociety.org/admin/emptyhomes/'; +} + +sub area_types { + return qw(DIS LBO MTD UTA LGD COI); # No CTY +} + + +sub base_url_with_lang { + my $self = shift; + my $email = shift; + + my $base = $self->base_url; + + if ($email) { + $base = $self->base_url_for_emails; + } + + my $lang = $mySociety::Locale::lang; + if ($lang eq 'cy') { + $base =~ s{http://}{$&cy.}; + } else { + $base =~ s{http://}{$&en.}; + } + return $base; +} + +=item set_lang_and_domain LANG UNICODE + +Set the language and text domain for the site based on the query and host. + +=cut + +sub set_lang_and_domain { + my ( $self, $lang, $unicode, $dir ) = @_; + my $set_lang = mySociety::Locale::negotiate_language( + 'en-gb,English,en_GB|cy,Cymraeg,cy_GB', $lang ); + mySociety::Locale::gettext_domain( 'FixMyStreet-EmptyHomes', $unicode, + $dir ); + mySociety::Locale::change(); + return $set_lang; +} + +=item site_title + +Return the title to be used in page heads + +=cut + +sub site_title { + my ($self) = @_; + return _('Report Empty Homes'); +} + +=item feed_xsl + +Return the XSL file path to be used for feeds' + +=cut + +sub feed_xsl { + my ($self) = @_; + return '/xsl.eha.xsl'; +} + +=item shorten_recency_if_new_greater_than_fixed + +For empty homes we don't want to shorten the recency + +=cut + +sub shorten_recency_if_new_greater_than_fixed { + return 0; +} + +=head2 generate_problem_banner + + my $banner = $c->cobrand->generate_problem_banner; + + <p id="[% banner.id %]:>[% banner.text %]</p> + +Generate id and text for banner that appears at top of problem page. + +=cut + +sub generate_problem_banner { + my ( $self, $problem ) = @_; + + my $banner = {}; + if ($problem->state eq 'fixed') { + $banner->{id} = 'fixed'; + $banner->{text} = _('This problem has been fixed') . '.'; + } + + return $banner; +} + +=head2 default_photo_resize + +Size that photos are to be resized to for display. If photos aren't +to be resized then return 0; + +=cut + +sub default_photo_resize { return '195x'; } + +=item council_rss_alert_options + +Generate a set of options for council rss alerts. + +=cut + +sub council_rss_alert_options { + my $self = shift; + my $all_councils = shift; + my $c = shift; + + my %councils = map { $_ => 1 } $self->area_types(); + + my $num_councils = scalar keys %$all_councils; + + my ( @options, @reported_to_options ); + my ($council, $ward); + foreach (values %$all_councils) { + $_->{short_name} = $self->short_name( $_ ); + ( $_->{id_name} = $_->{short_name} ) =~ tr/+/_/; + if ($councils{$_->{type}}) { + $council = $_; + } else { + $ward = $_; + } + } + + push @options, { + type => 'council', + id => sprintf( 'council:%s:%s', $council->{id}, $council->{id_name} ), + text => sprintf( _('Problems within %s'), $council->{name}), + rss_text => sprintf( _('RSS feed of problems within %s'), $council->{name}), + uri => $c->uri_for( '/rss/reports/' . $council->{short_name} ), + }; + push @options, { + type => 'ward', + id => sprintf( 'ward:%s:%s:%s:%s', $council->{id}, $ward->{id}, $council->{id_name}, $ward->{id_name} ), + rss_text => sprintf( _('RSS feed of problems within %s ward'), $ward->{name}), + text => sprintf( _('Problems within %s ward'), $ward->{name}), + uri => $c->uri_for( '/rss/reports/' . $council->{short_name} . '/' . $ward->{short_name} ), + }; + + return ( \@options, @reported_to_options ? \@reported_to_options : undef ); +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand/FiksGataMi.pm b/perllib/FixMyStreet/Cobrand/FiksGataMi.pm new file mode 100644 index 000000000..4f3b975b3 --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/FiksGataMi.pm @@ -0,0 +1,259 @@ +package FixMyStreet::Cobrand::FiksGataMi; +use base 'FixMyStreet::Cobrand::Default'; + +use strict; +use warnings; + +use Carp; +use mySociety::MaPit; +use FixMyStreet::Geocode::OSM; + +sub country { + return 'NO'; +} + +sub set_lang_and_domain { + my ( $self, $lang, $unicode, $dir ) = @_; + my $set_lang = mySociety::Locale::negotiate_language( + 'en-gb,English,en_GB|nb,Norwegian,nb_NO', 'nb' + ); + mySociety::Locale::gettext_domain( 'FixMyStreet', $unicode, $dir ); + mySociety::Locale::change(); + return $set_lang; +} + +sub enter_postcode_text { + my ( $self ) = @_; + return _('Enter a nearby postcode, or street name and area'); +} + +# Is also adding language parameter +sub disambiguate_location { + return { + lang => 'no', + country => 'no', + }; +} + +sub area_types { + return ( 'NKO', 'NFY', 'NRA' ); +} + +sub area_min_generation { + return ''; +} + +sub admin_base_url { + return 'http://www.fiksgatami.no/admin/'; +} + +sub writetothem_url { + return 'http://www.norge.no/styresmakter/'; +} + +# If lat/lon are present in the URL, OpenLayers will use that to centre the map. +# Need to specify a zoom to stop it defaulting to null/0. +sub uri { + my ( $self, $uri ) = @_; + + $uri->query_param( zoom => 3 ) + if $uri->query_param('lat') && !$uri->query_param('zoom'); + + return $uri; +} + +sub geocode_postcode { + my ( $self, $s ) = @_; + + if ($s =~ /^\d{4}$/) { + my $location = mySociety::MaPit::call('postcode', $s); + if ($location->{error}) { + return { + error => $location->{code} =~ /^4/ + ? _('That postcode was not recognised, sorry.') + : $location->{error} + }; + } + return { + latitude => $location->{wgs84_lat}, + longitude => $location->{wgs84_lon}, + }; + } + return {}; +} + +sub geocoded_string_check { + my ( $self, $s ) = @_; + return 1 if $s =~ /, Norge/; + return 0; +} + +sub find_closest { + my ( $self, $latitude, $longitude ) = @_; + return FixMyStreet::Geocode::OSM::closest_road_text( $self, $latitude, $longitude ); +} + +# Used by send-reports, calling find_closest, calling OSM geocoding +sub guess_road_operator { + my ( $self, $inforef ) = @_; + + my $highway = $inforef->{highway} || "unknown"; + my $refs = $inforef->{ref} || "unknown"; + + return "Statens vegvesen" + if $highway eq "trunk" || $highway eq "primary"; + + for my $ref (split(/;/, $refs)) { + return "Statens vegvesen" + if $ref =~ m/E ?\d+/ || $ref =~ m/Fv\d+/i; + } + return ''; +} + +sub remove_redundant_councils { + my $self = shift; + my $all_councils = shift; + + # Oslo is both a kommune and a fylke, we only want to show it once + delete $all_councils->{301} # + if $all_councils->{3}; +} + +sub filter_all_council_ids_list { + my $self = shift; + my @all_councils_ids = @_; + + # as above we only want to show Oslo once + return grep { $_ != 301 } @all_councils_ids; +} + +sub short_name { + my $self = shift; + my ($area, $info) = @_; + + if ($area->{name} =~ /^(Os|Nes|V\xe5ler|Sande|B\xf8|Her\xf8y)$/) { + my $parent = $info->{$area->{parent_area}}->{name}; + return URI::Escape::uri_escape_utf8("$area->{name}, $parent"); + } + + my $name = $area->{name}; + $name =~ s/ & / and /; + $name = URI::Escape::uri_escape_utf8($name); + $name =~ s/%20/+/g; + return $name; +} + +sub council_rss_alert_options { + my $self = shift; + my $all_councils = shift; + my $c = shift; + + my ( @options, @reported_to_options, $fylke, $kommune ); + + foreach ( values %$all_councils ) { + if ( $_->{type} eq 'NKO' ) { + $kommune = $_; + } + else { + $fylke = $_; + } + } + + if ( $fylke->{id} == 3 ) { # Oslo + my $short_name = $self->short_name($fylke, $all_councils); + ( my $id_name = $short_name ) =~ tr/+/_/; + + push @options, + { + type => 'council', + id => sprintf( 'council:%s:%s', $fylke->{id}, $id_name ), + rss_text => + sprintf( _('RSS feed of problems within %s'), $fylke->{name} ), + text => sprintf( _('Problems within %s'), $fylke->{name} ), + uri => $c->uri_for( '/rss/reports', $short_name ), + }; + } + else { + my $short_kommune_name = $self->short_name($kommune, $all_councils); + ( my $id_kommune_name = $short_kommune_name ) =~ tr/+/_/; + + my $short_fylke_name = $self->short_name($fylke, $all_councils); + ( my $id_fylke_name = $short_fylke_name ) =~ tr/+/_/; + + push @options, + { + type => 'area', + id => sprintf( 'area:%s:%s', $kommune->{id}, $id_kommune_name ), + rss_text => + sprintf( _('RSS feed of %s'), $kommune->{name} ), + text => $kommune->{name}, + uri => $c->uri_for( '/rss/area', $short_kommune_name ), + }, + { + type => 'area', + id => sprintf( 'area:%s:%s', $fylke->{id}, $id_fylke_name ), + rss_text => + sprintf( _('RSS feed of %s'), $fylke->{name} ), + text => $fylke->{name}, + uri => $c->uri_for( '/rss/area', $short_fylke_name ), + }; + + push @reported_to_options, + { + type => 'council', + id => sprintf( 'council:%s:%s', $kommune->{id}, $id_kommune_name ), + rss_text => + sprintf( _('RSS feed of %s'), $kommune->{name} ), + text => $kommune->{name}, + uri => $c->uri_for( '/rss/reports', $short_kommune_name ), + }, + { + type => 'council', + id => sprintf( 'council:%s:%s', $fylke->{id}, $id_fylke_name ), + rss_text => + sprintf( _('RSS feed of %s'), $fylke->{name} ), + text => $fylke->{name}, + uri => $c->uri_for( '/rss/reports/', $short_fylke_name ), + }; + } + + return ( + \@options, @reported_to_options + ? \@reported_to_options + : undef + ); + +} + +sub reports_council_check { + my ( $self, $c, $council ) = @_; + + if ($council eq 'Oslo') { + + # There are two Oslos (kommune and fylke), we only want one of them. + $c->stash->{council} = mySociety::MaPit::call('area', 3); + return 1; + + } elsif ($council =~ /,/) { + + # Some kommunes have the same name, use the fylke name to work out which. + my ($kommune, $fylke) = split /\s*,\s*/, $council; + my @area_types = $c->cobrand->area_types; + my $areas_k = mySociety::MaPit::call('areas', $kommune, type => \@area_types); + my $areas_f = mySociety::MaPit::call('areas', $fylke, type => \@area_types); + if (keys %$areas_f == 1) { + ($fylke) = values %$areas_f; + foreach (values %$areas_k) { + if ($_->{name} eq $kommune && $_->{parent_area} == $fylke->{id}) { + $c->stash->{council} = $_; + return 1; + } + } + } + # If we're here, we've been given a bad name. + $c->detach( 'redirect_index' ); + + } +} + +1; diff --git a/perllib/FixMyStreet/Cobrand/Southampton.pm b/perllib/FixMyStreet/Cobrand/Southampton.pm new file mode 100644 index 000000000..bd461f5e2 --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/Southampton.pm @@ -0,0 +1,80 @@ +package FixMyStreet::Cobrand::Southampton; +use base 'FixMyStreet::Cobrand::Default'; + +use strict; +use warnings; + +use Carp; +use URI::Escape; +use mySociety::VotingArea; + +sub site_restriction { + return ( "and council='2567'", 'southampton', { council => '2567' } ); +} + +sub problems_clause { + return { council => '2567' }; +} + +sub problems { + my $self = shift; + return $self->{c}->model('DB::Problem')->search( $self->problems_clause ); +} + +sub base_url { + my $base_url = mySociety::Config::get('BASE_URL'); + if ($base_url !~ /southampton/) { + $base_url =~ s{http://(?!www\.)}{http://southampton.}g; + $base_url =~ s{http://www\.}{http://southampton.}g; + } + return $base_url; +} + +sub site_title { + my ( $self ) = @_; + return 'Southampton City Council FixMyStreet'; +} + +sub enter_postcode_text { + my ( $self ) = @_; + return 'Enter a Southampton postcode, or street name and area'; +} + +sub council_check { + my ( $self, $params, $context ) = @_; + + my $councils = $params->{all_councils}; + my $council_match = defined $councils->{2567}; + if ($council_match) { + return 1; + } + my $url = 'http://www.fixmystreet.com/'; + $url .= 'alert' if $context eq 'alert'; + $url .= '?pc=' . URI::Escape::uri_escape_utf8($self->{c}->req->param('pc')) + if $self->{c}->req->param('pc'); + my $error_msg = "That location is not covered by Southampton. +Please visit <a href=\"$url\">the main FixMyStreet site</a>."; + return ( 0, $error_msg ); +} + +# All reports page only has the one council. +sub all_councils_report { + return 0; +} + +sub disambiguate_location { + return { + centre => '50.913822,-1.400493', + span => '0.084628,0.15701', + bounds => [ '50.871508,-1.478998', '50.956136,-1.321988' ], + }; +} + +sub recent_photos { + my ($self, $num, $lat, $lon, $dist) = @_; + $num = 2 if $num == 3; + return $self->problems->recent_photos( $num, $lat, $lon, $dist ); +} + +1; + diff --git a/perllib/FixMyStreet/DB.pm b/perllib/FixMyStreet/DB.pm new file mode 100644 index 000000000..18c8cc2ca --- /dev/null +++ b/perllib/FixMyStreet/DB.pm @@ -0,0 +1,17 @@ +package FixMyStreet::DB; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Schema'; + +__PACKAGE__->load_namespaces; + +# Created by DBIx::Class::Schema::Loader v0.07009 @ 2011-03-01 15:43:43 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:tJZ+CpaAfZVPrctDXTZTuQ + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Abuse.pm b/perllib/FixMyStreet/DB/Result/Abuse.pm new file mode 100644 index 000000000..b1cf9c1ed --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Abuse.pm @@ -0,0 +1,21 @@ +package FixMyStreet::DB::Result::Abuse; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("abuse"); +__PACKAGE__->add_columns("email", { data_type => "text", is_nullable => 0 }); +__PACKAGE__->set_primary_key("email"); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:IuTLiJSDZGLF/WX8q3iKIQ + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/AdminLog.pm b/perllib/FixMyStreet/DB/Result/AdminLog.pm new file mode 100644 index 000000000..da97950a0 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/AdminLog.pm @@ -0,0 +1,44 @@ +package FixMyStreet::DB::Result::AdminLog; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("admin_log"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "admin_log_id_seq", + }, + "admin_user", + { data_type => "text", is_nullable => 0 }, + "object_type", + { data_type => "text", is_nullable => 0 }, + "object_id", + { data_type => "integer", is_nullable => 0 }, + "action", + { data_type => "text", is_nullable => 0 }, + "whenedited", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, +); +__PACKAGE__->set_primary_key("id"); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:7427CuN3/6IL2GxiQDoWUA + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Alert.pm b/perllib/FixMyStreet/DB/Result/Alert.pm new file mode 100644 index 000000000..eddd98f37 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Alert.pm @@ -0,0 +1,127 @@ +package FixMyStreet::DB::Result::Alert; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("alert"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "alert_id_seq", + }, + "alert_type", + { data_type => "text", is_foreign_key => 1, is_nullable => 0 }, + "parameter", + { data_type => "text", is_nullable => 1 }, + "parameter2", + { data_type => "text", is_nullable => 1 }, + "confirmed", + { data_type => "integer", default_value => 0, is_nullable => 0 }, + "lang", + { data_type => "text", default_value => "en-gb", is_nullable => 0 }, + "cobrand", + { data_type => "text", default_value => "", is_nullable => 0 }, + "cobrand_data", + { data_type => "text", default_value => "", is_nullable => 0 }, + "whensubscribed", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, + "whendisabled", + { data_type => "timestamp", is_nullable => 1 }, + "user_id", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->belongs_to( + "alert_type", + "FixMyStreet::DB::Result::AlertType", + { ref => "alert_type" }, + { is_deferrable => 1, on_delete => "CASCADE", on_update => "CASCADE" }, +); +__PACKAGE__->belongs_to( + "user", + "FixMyStreet::DB::Result::User", + { id => "user_id" }, + { is_deferrable => 1, on_delete => "CASCADE", on_update => "CASCADE" }, +); +__PACKAGE__->has_many( + "alert_sents", + "FixMyStreet::DB::Result::AlertSent", + { "foreign.alert_id" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d2TrE9UIZdXu3eXYJH0Zmw + +# You can replace this text with custom code or comments, and it will be preserved on regeneration + +use DateTime::TimeZone; +use Moose; +use namespace::clean -except => [ 'meta' ]; + +with 'FixMyStreet::Roles::Abuser'; + +my $tz = DateTime::TimeZone->new( name => "local" ); + + +sub whensubscribed_local { + my $self = shift; + + return $self->whensubscribed + ? $self->whensubscribed->set_time_zone($tz) + : $self->whensubscribed; +} + +sub whendisabled_local { + my $self = shift; + + return $self->whendisabled + ? $self->whendisabled->set_time_zone($tz) + : $self->whendisabled; +} + +=head2 confirm + + $alert->confirm(); + +Sets the state of the alert to confirmed. + +=cut + +sub confirm { + my $self = shift; + + $self->confirmed(1); + $self->whendisabled(undef); + $self->update; + + return 1; +} + +sub disable { + my $self = shift; + + $self->whendisabled( \'ms_current_timestamp()' ); + $self->update; + + return 1; +} + +# need the inline_constuctor bit as we don't inherit from Moose +__PACKAGE__->meta->make_immutable( inline_constructor => 0 ); + +1; diff --git a/perllib/FixMyStreet/DB/Result/AlertSent.pm b/perllib/FixMyStreet/DB/Result/AlertSent.pm new file mode 100644 index 000000000..a901c2fde --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/AlertSent.pm @@ -0,0 +1,38 @@ +package FixMyStreet::DB::Result::AlertSent; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("alert_sent"); +__PACKAGE__->add_columns( + "alert_id", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "parameter", + { data_type => "text", is_nullable => 1 }, + "whenqueued", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, +); +__PACKAGE__->belongs_to( + "alert", + "FixMyStreet::DB::Result::Alert", + { id => "alert_id" }, + { is_deferrable => 1, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:fTiWIoriQUvHpWc9PpFLvA + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/AlertType.pm b/perllib/FixMyStreet/DB/Result/AlertType.pm new file mode 100644 index 000000000..d23a2983d --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/AlertType.pm @@ -0,0 +1,55 @@ +package FixMyStreet::DB::Result::AlertType; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("alert_type"); +__PACKAGE__->add_columns( + "ref", + { data_type => "text", is_nullable => 0 }, + "head_sql_query", + { data_type => "text", is_nullable => 0 }, + "head_table", + { data_type => "text", is_nullable => 0 }, + "head_title", + { data_type => "text", is_nullable => 0 }, + "head_link", + { data_type => "text", is_nullable => 0 }, + "head_description", + { data_type => "text", is_nullable => 0 }, + "item_table", + { data_type => "text", is_nullable => 0 }, + "item_where", + { data_type => "text", is_nullable => 0 }, + "item_order", + { data_type => "text", is_nullable => 0 }, + "item_title", + { data_type => "text", is_nullable => 0 }, + "item_link", + { data_type => "text", is_nullable => 0 }, + "item_description", + { data_type => "text", is_nullable => 0 }, + "template", + { data_type => "text", is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("ref"); +__PACKAGE__->has_many( + "alerts", + "FixMyStreet::DB::Result::Alert", + { "foreign.alert_type" => "self.ref" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:+PKqo7IZ4MlM9ur4V2P9tA + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Comment.pm b/perllib/FixMyStreet/DB/Result/Comment.pm new file mode 100644 index 000000000..ae152eb31 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Comment.pm @@ -0,0 +1,153 @@ +package FixMyStreet::DB::Result::Comment; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("comment"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "comment_id_seq", + }, + "problem_id", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "name", + { data_type => "text", is_nullable => 1 }, + "website", + { data_type => "text", is_nullable => 1 }, + "created", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, + "confirmed", + { data_type => "timestamp", is_nullable => 1 }, + "text", + { data_type => "text", is_nullable => 0 }, + "photo", + { data_type => "bytea", is_nullable => 1 }, + "state", + { data_type => "text", is_nullable => 0 }, + "cobrand", + { data_type => "text", default_value => "", is_nullable => 0 }, + "lang", + { data_type => "text", default_value => "en-gb", is_nullable => 0 }, + "cobrand_data", + { data_type => "text", default_value => "", is_nullable => 0 }, + "mark_fixed", + { data_type => "boolean", is_nullable => 0 }, + "mark_open", + { data_type => "boolean", default_value => \"false", is_nullable => 0 }, + "user_id", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "anonymous", + { data_type => "boolean", is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->belongs_to( + "user", + "FixMyStreet::DB::Result::User", + { id => "user_id" }, + { is_deferrable => 1, on_delete => "CASCADE", on_update => "CASCADE" }, +); +__PACKAGE__->belongs_to( + "problem", + "FixMyStreet::DB::Result::Problem", + { id => "problem_id" }, + { is_deferrable => 1, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:TYFusbxkOkAewaiZYZVJUA + +use DateTime::TimeZone; +use Image::Size; +use Moose; +use namespace::clean -except => [ 'meta' ]; + +with 'FixMyStreet::Roles::Abuser'; + +my $tz = DateTime::TimeZone->new( name => "local" ); + +sub created_local { + my $self = shift; + + return $self->created + ? $self->created->set_time_zone($tz) + : $self->created; +} + +sub confirmed_local { + my $self = shift; + + # if confirmed is null then it doesn't get inflated so don't + # try and set the timezone + return $self->confirmed + ? $self->confirmed->set_time_zone($tz) + : $self->confirmed; +} + +# You can replace this text with custom code or comments, and it will be preserved on regeneration + +sub check_for_errors { + my $self = shift; + + my %errors = (); + + $errors{name} = _('Please enter your name') + if !$self->name || $self->name !~ m/\S/; + + $errors{update} = _('Please enter a message') + unless $self->text =~ m/\S/; + + return \%errors; +} + +=head2 confirm + +Set state of comment to confirmed + +=cut + +sub confirm { + my $self = shift; + + $self->state( 'confirmed' ); + $self->confirmed( \'ms_current_timestamp()' ); +} + +=head2 get_photo_params + +Returns a hashref of details of any attached photo for use in templates. +Hashref contains height, width and url keys. + +=cut + +sub get_photo_params { + my $self = shift; + + return {} unless $self->photo; + + my $photo = {}; + ( $photo->{width}, $photo->{height} ) = + Image::Size::imgsize( \$self->photo ); + $photo->{url} = '/photo?c=' . $self->id; + + return $photo; +} + +# we need the inline_constructor bit as we don't inherit from Moose +__PACKAGE__->meta->make_immutable( inline_constructor => 0 ); + +1; diff --git a/perllib/FixMyStreet/DB/Result/Contact.pm b/perllib/FixMyStreet/DB/Result/Contact.pm new file mode 100644 index 000000000..001fb4ac6 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Contact.pm @@ -0,0 +1,45 @@ +package FixMyStreet::DB::Result::Contact; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("contacts"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "contacts_id_seq", + }, + "area_id", + { data_type => "integer", is_nullable => 0 }, + "category", + { data_type => "text", default_value => "Other", is_nullable => 0 }, + "email", + { data_type => "text", is_nullable => 0 }, + "confirmed", + { data_type => "boolean", is_nullable => 0 }, + "deleted", + { data_type => "boolean", is_nullable => 0 }, + "editor", + { data_type => "text", is_nullable => 0 }, + "whenedited", + { data_type => "timestamp", is_nullable => 0 }, + "note", + { data_type => "text", is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->add_unique_constraint("contacts_area_id_category_idx", ["area_id", "category"]); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:BXGd4uk1ybC5RTKlInTr0w + +1; diff --git a/perllib/FixMyStreet/DB/Result/ContactsHistory.pm b/perllib/FixMyStreet/DB/Result/ContactsHistory.pm new file mode 100644 index 000000000..811a06b44 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/ContactsHistory.pm @@ -0,0 +1,48 @@ +package FixMyStreet::DB::Result::ContactsHistory; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("contacts_history"); +__PACKAGE__->add_columns( + "contacts_history_id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "contacts_history_contacts_history_id_seq", + }, + "contact_id", + { data_type => "integer", is_nullable => 0 }, + "area_id", + { data_type => "integer", is_nullable => 0 }, + "category", + { data_type => "text", default_value => "Other", is_nullable => 0 }, + "email", + { data_type => "text", is_nullable => 0 }, + "confirmed", + { data_type => "boolean", is_nullable => 0 }, + "deleted", + { data_type => "boolean", is_nullable => 0 }, + "editor", + { data_type => "text", is_nullable => 0 }, + "whenedited", + { data_type => "timestamp", is_nullable => 0 }, + "note", + { data_type => "text", is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("contacts_history_id"); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:9APvBwAOebG5g4MGxJuVKQ + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Nearby.pm b/perllib/FixMyStreet/DB/Result/Nearby.pm new file mode 100644 index 000000000..d3d228788 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Nearby.pm @@ -0,0 +1,33 @@ +package FixMyStreet::DB::Result::Nearby; + +# Thanks to http://www.perlmonks.org/?node_id=633800 + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; +use Moose; +use namespace::clean -except => [ 'meta' ]; + +__PACKAGE__->table( 'NONE' ); +__PACKAGE__->add_columns( + "problem_id", + { data_type => "integer", is_nullable => 0 }, + "distance", + { data_type => "double precision", is_nullable => 0 }, +); +__PACKAGE__->belongs_to( + "problem", + "FixMyStreet::DB::Result::Problem", + { id => "problem_id" }, + { is_deferrable => 1 }, +); + +# Make a new ResultSource based on the User class +__PACKAGE__->result_source_instance + ->name( \'problem_find_nearby(?,?,?)' ); + +# we need the inline_constructor bit as we don't inherit from Moose +__PACKAGE__->meta->make_immutable( inline_constructor => 0 ); + +1; diff --git a/perllib/FixMyStreet/DB/Result/Problem.pm b/perllib/FixMyStreet/DB/Result/Problem.pm new file mode 100644 index 000000000..ff730958a --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Problem.pm @@ -0,0 +1,404 @@ +package FixMyStreet::DB::Result::Problem; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("problem"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "problem_id_seq", + }, + "postcode", + { data_type => "text", is_nullable => 0 }, + "latitude", + { data_type => "double precision", is_nullable => 0 }, + "longitude", + { data_type => "double precision", is_nullable => 0 }, + "council", + { data_type => "text", is_nullable => 1 }, + "areas", + { data_type => "text", is_nullable => 0 }, + "category", + { data_type => "text", default_value => "Other", is_nullable => 0 }, + "title", + { data_type => "text", is_nullable => 0 }, + "detail", + { data_type => "text", is_nullable => 0 }, + "photo", + { data_type => "bytea", is_nullable => 1 }, + "used_map", + { data_type => "boolean", is_nullable => 0 }, + "user_id", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "name", + { data_type => "text", is_nullable => 0 }, + "anonymous", + { data_type => "boolean", is_nullable => 0 }, + "external_id", + { data_type => "text", is_nullable => 1 }, + "external_body", + { data_type => "text", is_nullable => 1 }, + "external_team", + { data_type => "text", is_nullable => 1 }, + "created", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, + "confirmed", + { data_type => "timestamp", is_nullable => 1 }, + "state", + { data_type => "text", is_nullable => 0 }, + "lang", + { data_type => "text", default_value => "en-gb", is_nullable => 0 }, + "service", + { data_type => "text", default_value => "", is_nullable => 0 }, + "cobrand", + { data_type => "text", default_value => "", is_nullable => 0 }, + "cobrand_data", + { data_type => "text", default_value => "", is_nullable => 0 }, + "lastupdate", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, + "whensent", + { data_type => "timestamp", is_nullable => 1 }, + "send_questionnaire", + { data_type => "boolean", default_value => \"true", is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->has_many( + "comments", + "FixMyStreet::DB::Result::Comment", + { "foreign.problem_id" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); +__PACKAGE__->belongs_to( + "user", + "FixMyStreet::DB::Result::User", + { id => "user_id" }, + { is_deferrable => 1, on_delete => "CASCADE", on_update => "CASCADE" }, +); +__PACKAGE__->has_many( + "questionnaires", + "FixMyStreet::DB::Result::Questionnaire", + { "foreign.problem_id" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:3sw/1dqxlTvcWEI/eJTm4w + +# Add fake relationship to stored procedure table +__PACKAGE__->has_many( + "nearby", + "FixMyStreet::DB::Result::Nearby", + { "foreign.problem_id" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +use DateTime::TimeZone; +use Image::Size; +use Moose; +use namespace::clean -except => [ 'meta' ]; +use Utils; + +with 'FixMyStreet::Roles::Abuser'; + +my $tz = DateTime::TimeZone->new( name => "local" ); + +sub confirmed_local { + my $self = shift; + + return $self->confirmed + ? $self->confirmed->set_time_zone($tz) + : $self->confirmed; +} + +sub created_local { + my $self = shift; + + return $self->created + ? $self->created->set_time_zone($tz) + : $self->created; +} + +sub whensent_local { + my $self = shift; + + return $self->whensent + ? $self->whensent->set_time_zone($tz) + : $self->whensent; +} + +sub lastupdate_local { + my $self = shift; + + return $self->lastupdate + ? $self->lastupdate->set_time_zone($tz) + : $self->lastupdate; +} + +around service => sub { + my ( $orig, $self ) = ( shift, shift ); + my $s = $self->$orig(@_); + $s =~ s/_/ /g; + return $s; +}; + +=head2 check_for_errors + + $error_hashref = $problem->check_for_errors(); + +Look at all the fields and return a hashref with all errors found, keyed on the +field name. This is intended to be passed back to the form to display the +errors. + +TODO - ideally we'd pass back error codes which would be humanised in the +templates (eg: 'missing','email_not_valid', etc). + +=cut + +sub check_for_errors { + my $self = shift; + + my %errors = (); + + $errors{title} = _('Please enter a subject') + unless $self->title =~ m/\S/; + + $errors{detail} = _('Please enter some details') + unless $self->detail =~ m/\S/; + + $errors{council} = _('No council selected') + unless $self->council + && $self->council =~ m/^(?:-1|[\d,]+(?:\|[\d,]+)?)$/; + + if ( !$self->name || $self->name !~ m/\S/ ) { + $errors{name} = _('Please enter your name'); + } + elsif (length( $self->name ) < 5 + || $self->name !~ m/\s/ + || $self->name =~ m/\ba\s*n+on+((y|o)mo?u?s)?(ly)?\b/i ) + { + $errors{name} = _( +'Please enter your full name, councils need this information - if you do not wish your name to be shown on the site, untick the box' + ); + } + + if ( $self->category + && $self->category eq _('-- Pick a category --') ) + { + $errors{category} = _('Please choose a category'); + $self->category(undef); + } + elsif ($self->category + && $self->category eq _('-- Pick a property type --') ) + { + $errors{category} = _('Please choose a property type'); + $self->category(undef); + } + + return \%errors; +} + +=head2 confirm + + $bool = $problem->confirm( ); + $problem->update; + + +Set the state to 'confirmed' and put current time into 'confirmed' field. This +is a no-op if the report is already confirmed. + +NOTE - does not update storage - call update or insert to do that. + +=cut + +sub confirm { + my $self = shift; + + return if $self->state eq 'confirmed'; + + $self->state('confirmed'); + $self->confirmed( \'ms_current_timestamp()' ); + return 1; +} + +=head2 councils + +Returns an arrayref of councils to which a report was sent. + +=cut + +sub councils { + my $self = shift; + return [] unless $self->council; + (my $council = $self->council) =~ s/\|.*$//; + my @council = split( /,/, $council ); + return \@council; +} + +=head2 url + +Returns a URL for this problem report. + +=cut + +sub url { + my $self = shift; + return "/report/" . $self->id; +} + +=head2 get_photo_params + +Returns a hashref of details of any attached photo for use in templates. +Hashref contains height, width and url keys. + +=cut + +sub get_photo_params { + my $self = shift; + + return {} unless $self->photo; + + my $photo = {}; + ( $photo->{width}, $photo->{height} ) = + Image::Size::imgsize( \$self->photo ); + $photo->{url} = '/photo?id=' . $self->id; + + return $photo; +} + +=head2 meta_line + +Returns a string to be used on a problem report page, describing some of the +meta data about the report. + +=cut + +sub meta_line { + my ( $problem, $c ) = @_; + + my $date_time = + Utils::prettify_epoch( $problem->confirmed_local->epoch ); + my $meta = ''; + + # FIXME Should be in cobrand + if ($c->cobrand->moniker eq 'emptyhomes') { + + my $category = _($problem->category); + utf8::decode($category); + if ($problem->anonymous) { + $meta = sprintf(_('%s, reported anonymously at %s'), $category, $date_time); + } else { + $meta = sprintf(_('%s, reported by %s at %s'), $category, $problem->name, $date_time); + } + + } else { + + if ( $problem->anonymous ) { + if ( $problem->service + and $problem->category && $problem->category ne _('Other') ) + { + $meta = + sprintf( _('Reported by %s in the %s category anonymously at %s'), + $problem->service, $problem->category, $date_time ); + } + elsif ( $problem->service ) { + $meta = sprintf( _('Reported by %s anonymously at %s'), + $problem->service, $date_time ); + } + elsif ( $problem->category and $problem->category ne _('Other') ) { + $meta = sprintf( _('Reported in the %s category anonymously at %s'), + $problem->category, $date_time ); + } + else { + $meta = sprintf( _('Reported anonymously at %s'), $date_time ); + } + } + else { + if ( $problem->service + and $problem->category && $problem->category ne _('Other') ) + { + $meta = sprintf( + _('Reported by %s in the %s category by %s at %s'), + $problem->service, $problem->category, + $problem->name, $date_time + ); + } + elsif ( $problem->service ) { + $meta = sprintf( _('Reported by %s by %s at %s'), + $problem->service, $problem->name, $date_time ); + } + elsif ( $problem->category and $problem->category ne _('Other') ) { + $meta = sprintf( _('Reported in the %s category by %s at %s'), + $problem->category, $problem->name, $date_time ); + } + else { + $meta = + sprintf( _('Reported by %s at %s'), $problem->name, $date_time ); + } + } + + } + + $meta .= $c->cobrand->extra_problem_meta_text($problem); + $meta .= '; ' . _('the map was not used so pin location may be inaccurate') + unless $problem->used_map; + + return $meta; +} + +sub body { + my ( $problem, $c ) = @_; + my $body; + if ($problem->external_body) { + $body = $problem->external_body; + } else { + (my $council = $problem->council) =~ s/\|.*//g; + my @councils = split( /,/, $council ); + my $areas_info = mySociety::MaPit::call('areas', \@councils); + $body = join( _(' and '), + map { + my $name = $areas_info->{$_}->{name}; + if (mySociety::Config::get('AREA_LINKS_FROM_PROBLEMS')) { + '<a href="' + . $c->uri_for( '/reports/' . $c->cobrand->short_name( $areas_info->{$_} ) ) + . '">' . $name . '</a>'; + } else { + $name; + } + } @councils + ); + } + return $body; +} + +# TODO Some/much of this could be moved to the template +sub duration_string { + my ( $problem, $c ) = @_; + my $body = $problem->body( $c ); + return sprintf(_('Sent to %s %s later'), $body, + Utils::prettify_duration($problem->whensent_local->epoch - $problem->confirmed_local->epoch, 'minute') + ); +} + +# we need the inline_constructor bit as we don't inherit from Moose +__PACKAGE__->meta->make_immutable( inline_constructor => 0 ); + +1; diff --git a/perllib/FixMyStreet/DB/Result/Questionnaire.pm b/perllib/FixMyStreet/DB/Result/Questionnaire.pm new file mode 100644 index 000000000..cc4ec300b --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Questionnaire.pm @@ -0,0 +1,66 @@ +package FixMyStreet::DB::Result::Questionnaire; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("questionnaire"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "questionnaire_id_seq", + }, + "problem_id", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "whensent", + { data_type => "timestamp", is_nullable => 0 }, + "whenanswered", + { data_type => "timestamp", is_nullable => 1 }, + "ever_reported", + { data_type => "boolean", is_nullable => 1 }, + "old_state", + { data_type => "text", is_nullable => 1 }, + "new_state", + { data_type => "text", is_nullable => 1 }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->belongs_to( + "problem", + "FixMyStreet::DB::Result::Problem", + { id => "problem_id" }, + { is_deferrable => 1, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:QNFqqCg6J4SFlg4zwm7TWw + +use DateTime::TimeZone; + +my $tz = DateTime::TimeZone->new( name => "local" ); + +sub whensent_local { + my $self = shift; + + return $self->whensent + ? $self->whensent->set_time_zone($tz) + : $self->whensent; +} + +sub whenanswered_local { + my $self = shift; + + return $self->whenanswered + ? $self->whenanswered->set_time_zone($tz) + : $self->whenanswered; +} + +1; diff --git a/perllib/FixMyStreet/DB/Result/Secret.pm b/perllib/FixMyStreet/DB/Result/Secret.pm new file mode 100644 index 000000000..8a1fa671d --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Secret.pm @@ -0,0 +1,21 @@ +package FixMyStreet::DB::Result::Secret; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("secret"); +__PACKAGE__->add_columns("secret", { data_type => "text", is_nullable => 0 }); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:MfqW1K0aFtwpa/1c/UwHjg + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Session.pm b/perllib/FixMyStreet/DB/Result/Session.pm new file mode 100644 index 000000000..9d5d509dc --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Session.pm @@ -0,0 +1,28 @@ +package FixMyStreet::DB::Result::Session; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("sessions"); +__PACKAGE__->add_columns( + "id", + { data_type => "char", is_nullable => 0, size => 72 }, + "session_data", + { data_type => "text", is_nullable => 1 }, + "expires", + { data_type => "integer", is_nullable => 1 }, +); +__PACKAGE__->set_primary_key("id"); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:TagSQOXnDttkwfJ7oDH8Yw + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Token.pm b/perllib/FixMyStreet/DB/Result/Token.pm new file mode 100644 index 000000000..3a900858d --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Token.pm @@ -0,0 +1,87 @@ +package FixMyStreet::DB::Result::Token; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("token"); +__PACKAGE__->add_columns( + "scope", + { data_type => "text", is_nullable => 0 }, + "token", + { data_type => "text", is_nullable => 0 }, + "data", + { data_type => "bytea", is_nullable => 0 }, + "created", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, +); +__PACKAGE__->set_primary_key("scope", "token"); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:frl+na3HrIzGw9D1t891nA + +# Trying not to use this +# use mySociety::DBHandle qw(dbh); + +use mySociety::AuthToken; +use IO::String; +use RABX; + +=head1 NAME + +FixMyStreet::DB::Result::Token + +=head2 DESCRIPTION + +Representation of mySociety::AuthToken in the DBIx::Class world. + +Mostly done so that we don't need to use mySociety::DBHandle. + +The 'data' value is automatically inflated and deflated in the same way that the +AuthToken would do it. 'token' is set to a new random value by default and the +'created' timestamp is achieved using the database function +ms_current_timestamp. + +=cut + +__PACKAGE__->filter_column( + data => { + filter_from_storage => sub { + my $self = shift; + my $ser = shift; + return undef unless defined $ser; + my $h = new IO::String($ser); + return RABX::wire_rd($h); + }, + filter_to_storage => sub { + my $self = shift; + my $data = shift; + my $ser = ''; + my $h = new IO::String($ser); + RABX::wire_wr( $data, $h ); + return $ser; + }, + } +); + +sub new { + my ( $class, $attrs ) = @_; + + $attrs->{token} ||= mySociety::AuthToken::random_token(); + $attrs->{created} ||= \'ms_current_timestamp()'; + + my $new = $class->next::method($attrs); + return $new; +} + +1; diff --git a/perllib/FixMyStreet/DB/Result/User.pm b/perllib/FixMyStreet/DB/Result/User.pm new file mode 100644 index 000000000..4ee413a58 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/User.pm @@ -0,0 +1,135 @@ +package FixMyStreet::DB::Result::User; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn", "InflateColumn::DateTime", "EncodedColumn"); +__PACKAGE__->table("users"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "users_id_seq", + }, + "email", + { data_type => "text", is_nullable => 0 }, + "name", + { data_type => "text", is_nullable => 1 }, + "phone", + { data_type => "text", is_nullable => 1 }, + "password", + { data_type => "text", default_value => "", is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->add_unique_constraint("users_email_key", ["email"]); +__PACKAGE__->has_many( + "alerts", + "FixMyStreet::DB::Result::Alert", + { "foreign.user_id" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); +__PACKAGE__->has_many( + "comments", + "FixMyStreet::DB::Result::Comment", + { "foreign.user_id" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); +__PACKAGE__->has_many( + "problems", + "FixMyStreet::DB::Result::Problem", + { "foreign.user_id" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-06-23 15:49:48 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:T2JK+KyfoE2hkCLgreq1XQ + +__PACKAGE__->add_columns( + "password" => { + encode_column => 1, + encode_class => 'Crypt::Eksblowfish::Bcrypt', + encode_args => { cost => 8 }, + encode_check_method => 'check_password', + }, +); + +use mySociety::EmailUtil; + +=head2 check_for_errors + + $error_hashref = $problem->check_for_errors(); + +Look at all the fields and return a hashref with all errors found, keyed on the +field name. This is intended to be passed back to the form to display the +errors. + +TODO - ideally we'd pass back error codes which would be humanised in the +templates (eg: 'missing','email_not_valid', etc). + +=cut + +sub check_for_errors { + my $self = shift; + + my %errors = (); + + if ( !$self->name || $self->name !~ m/\S/ ) { + $errors{name} = _('Please enter your name'); + } + + if ( $self->email !~ /\S/ ) { + $errors{email} = _('Please enter your email'); + } + elsif ( !mySociety::EmailUtil::is_valid_email( $self->email ) ) { + $errors{email} = _('Please enter a valid email'); + } + + return \%errors; +} + +=head2 answered_ever_reported + +Check if the user has ever answered a questionnaire. + +=cut + +sub answered_ever_reported { + my $self = shift; + + my $has_answered = + $self->result_source->schema->resultset('Questionnaire')->search( + { + ever_reported => { not => undef }, + problem_id => { -in => + $self->problems->get_column('id')->as_query }, + } + ); + + return $has_answered->count > 0; +} + +=head2 alert_for_problem + +Returns whether the user is already subscribed to an +alert for the problem ID provided. + +=cut + +sub alert_for_problem { + my ( $self, $id ) = @_; + + return $self->alerts->find( { + alert_type => 'new_updates', + parameter => $id, + } ); +} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/Alert.pm b/perllib/FixMyStreet/DB/ResultSet/Alert.pm new file mode 100644 index 000000000..5848265f1 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/Alert.pm @@ -0,0 +1,50 @@ +package FixMyStreet::DB::ResultSet::Alert; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + +sub timeline_created { + my ( $rs, $restriction ) = @_; + + my $prefetch = + FixMyStreet::App->model('DB')->schema->storage->sql_maker->quote_char ? + [ qw/alert_type user/ ] : + [ qw/alert_type/ ]; + + return $rs->search( + { + whensubscribed => { '>=', \"ms_current_timestamp()-'7 days'::interval" }, + confirmed => 1, + %{ $restriction }, + }, + { + prefetch => $prefetch, + } + ); +} + +sub timeline_disabled { + my ( $rs, $restriction ) = @_; + + return $rs->search( + { + whendisabled => { '>=', \"ms_current_timestamp()-'7 days'::interval" }, + %{ $restriction }, + }, + ); +} + +sub summary_count { + my ( $rs, $restriction ) = @_; + + return $rs->search( + $restriction, + { + group_by => ['confirmed'], + select => [ 'confirmed', { count => 'id' } ], + as => [qw/confirmed confirmed_count/] + } + ); +} +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/AlertType.pm b/perllib/FixMyStreet/DB/ResultSet/AlertType.pm new file mode 100644 index 000000000..46009cb85 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/AlertType.pm @@ -0,0 +1,210 @@ +package FixMyStreet::DB::ResultSet::AlertType; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + +use File::Slurp; + +use mySociety::DBHandle qw(dbh); +use mySociety::EmailUtil; +use mySociety::Gaze; +use mySociety::Locale; +use mySociety::MaPit; + +# Child must have confirmed, id, email, state(!) columns +# If parent/child, child table must also have name and text +# and foreign key to parent must be PARENT_id +sub email_alerts ($) { + my ( $rs ) = @_; + + my $q = $rs->search( { ref => { -not_like => '%local_problems%' } } ); + while (my $alert_type = $q->next) { + my $ref = $alert_type->ref; + my $head_table = $alert_type->head_table; + my $item_table = $alert_type->item_table; + my $query = 'select alert.id as alert_id, alert.user_id as alert_user_id, alert.lang as alert_lang, alert.cobrand as alert_cobrand, + alert.cobrand_data as alert_cobrand_data, alert.parameter as alert_parameter, alert.parameter2 as alert_parameter2, '; + if ($head_table) { + $query .= " + $item_table.id as item_id, $item_table.text as item_text, + $item_table.name as item_name, $item_table.anonymous as item_anonymous, + $head_table.* + from alert + inner join $item_table on alert.parameter::integer = $item_table.${head_table}_id + inner join $head_table on alert.parameter::integer = $head_table.id + "; + } else { + $query .= " $item_table.*, + $item_table.id as item_id + from alert, $item_table"; + } + $query .= " + where alert_type='$ref' and whendisabled is null and $item_table.confirmed >= whensubscribed + and $item_table.confirmed >= ms_current_timestamp() - '7 days'::interval + and (select whenqueued from alert_sent where alert_sent.alert_id = alert.id and alert_sent.parameter::integer = $item_table.id) is null + and $item_table.user_id <> alert.user_id + and " . $alert_type->item_where . " + and alert.confirmed = 1 + order by alert.id, $item_table.confirmed"; + # XXX Ugh - needs work + $query =~ s/\?/alert.parameter/ if ($query =~ /\?/); + $query =~ s/\?/alert.parameter2/ if ($query =~ /\?/); + $query = dbh()->prepare($query); + $query->execute(); + my $last_alert_id; + my %data = ( template => $alert_type->template, data => '' ); + while (my $row = $query->fetchrow_hashref) { + + my $cobrand = FixMyStreet::Cobrand->get_class_for_moniker($row->{alert_cobrand})->new(); + + # Cobranded and non-cobranded messages can share a database. In this case, the conf file + # should specify a vhost to send the reports for each cobrand, so that they don't get sent + # more than once if there are multiple vhosts running off the same database. The email_host + # call checks if this is the host that sends mail for this cobrand. + next unless $cobrand->email_host; + + FixMyStreet::App->model('DB::AlertSent')->create( { + alert_id => $row->{alert_id}, + parameter => $row->{item_id}, + } ); + if ($last_alert_id && $last_alert_id != $row->{alert_id}) { + _send_aggregated_alert_email(%data); + %data = ( template => $alert_type->template, data => '' ); + } + + # create problem status message for the templates + $data{state_message} = + $row->{state} eq 'fixed' + ? _("This report is currently marked as fixed.") + : _("This report is currently marked as open."); + + my $url = $cobrand->base_url_for_emails( $row->{alert_cobrand_data} ); + if ($row->{item_text}) { + $data{problem_url} = $url . "/report/" . $row->{id}; + $data{data} .= $row->{item_name} . ' : ' if $row->{item_name} && !$row->{item_anonymous}; + $data{data} .= $row->{item_text} . "\n\n------\n\n"; + } else { + $data{data} .= $url . "/report/" . $row->{id} . " - $row->{title}\n\n"; + } + if (!$data{alert_user_id}) { + %data = (%data, %$row); + if ($ref eq 'area_problems' || $ref eq 'council_problems' || $ref eq 'ward_problems') { + my $va_info = mySociety::MaPit::call('area', $row->{alert_parameter}); + $data{area_name} = $va_info->{name}; + } + if ($ref eq 'ward_problems') { + my $va_info = mySociety::MaPit::call('area', $row->{alert_parameter2}); + $data{ward_name} = $va_info->{name}; + } + } + $data{cobrand} = $row->{alert_cobrand}; + $data{cobrand_data} = $row->{alert_cobrand_data}; + $data{lang} = $row->{alert_lang}; + $last_alert_id = $row->{alert_id}; + } + if ($last_alert_id) { + _send_aggregated_alert_email(%data); + } + } + + # Nearby done separately as the table contains the parameters + my $template = $rs->find( { ref => 'local_problems' } )->template; + my $query = FixMyStreet::App->model('DB::Alert')->search( { + alert_type => 'local_problems', + whendisabled => undef, + confirmed => 1 + }, { + order_by => 'id' + } ); + while (my $alert = $query->next) { + my $cobrand = FixMyStreet::Cobrand->get_class_for_moniker($alert->cobrand)->new(); + next unless $cobrand->email_host; + + my $longitude = $alert->parameter; + my $latitude = $alert->parameter2; + my $url = $cobrand->base_url_for_emails( $alert->cobrand_data ); + my ($site_restriction, $site_id) = $cobrand->site_restriction( $alert->cobrand_data ); + my $d = mySociety::Gaze::get_radius_containing_population($latitude, $longitude, 200000); + # Convert integer to GB locale string (with a ".") + $d = mySociety::Locale::in_gb_locale { + sprintf("%f", int($d*10+0.5)/10); + }; + my %data = ( template => $template, data => '', alert_id => $alert->id, alert_email => $alert->user->email, lang => $alert->lang, cobrand => $alert->cobrand, cobrand_data => $alert->cobrand_data ); + my $q = "select problem.id, problem.title from problem_find_nearby(?, ?, ?) as nearby, problem, users + where nearby.problem_id = problem.id + and problem.user_id = users.id + and problem.state in ('confirmed', 'fixed') + and problem.confirmed >= ? and problem.confirmed >= ms_current_timestamp() - '7 days'::interval + and (select whenqueued from alert_sent where alert_sent.alert_id = ? and alert_sent.parameter::integer = problem.id) is null + and users.email <> ? + $site_restriction + order by confirmed desc"; + $q = dbh()->prepare($q); + $q->execute($latitude, $longitude, $d, $alert->whensubscribed, $alert->id, $alert->user->email); + while (my $row = $q->fetchrow_hashref) { + FixMyStreet::App->model('DB::AlertSent')->create( { + alert_id => $alert->id, + parameter => $row->{id}, + } ); + $data{data} .= $url . "/report/" . $row->{id} . " - $row->{title}\n\n"; + } + _send_aggregated_alert_email(%data) if $data{data}; + } +} + +sub _send_aggregated_alert_email(%) { + my %data = @_; + + my $cobrand = FixMyStreet::Cobrand->get_class_for_moniker($data{cobrand})->new(); + + $cobrand->set_lang_and_domain( $data{lang}, 1 ); + + if (!$data{alert_email}) { + my $user = FixMyStreet::App->model('DB::User')->find( { + id => $data{alert_user_id} + } ); + $data{alert_email} = $user->email; + } + + my $token = FixMyStreet::App->model("DB::Token")->new_result( { + scope => 'alert', + data => { + id => $data{alert_id}, + type => 'unsubscribe', + email => $data{alert_email}, + } + } ); + $data{unsubscribe_url} = $cobrand->base_url_for_emails( $data{cobrand_data} ) . '/A/' . $token->token; + + my $template = FixMyStreet->path_to( + "templates", "email", $cobrand->moniker, $data{lang}, "$data{template}.txt" + )->stringify; + $template = FixMyStreet->path_to( "templates", "email", $cobrand->moniker, "$data{template}.txt" )->stringify + unless -e $template; + $template = FixMyStreet->path_to( "templates", "email", "default", "$data{template}.txt" )->stringify + unless -e $template; + $template = File::Slurp::read_file($template); + + my $sender = $cobrand->contact_email; + (my $from = $sender) =~ s/team/fms-DO-NOT-REPLY/; # XXX + my $result = FixMyStreet::App->send_email_cron( + { + _template_ => $template, + _parameters_ => \%data, + From => [ $from, _($cobrand->contact_name) ], + To => $data{alert_email}, + }, + $sender, + [ $data{alert_email} ], + 0, + ); + + if ($result == mySociety::EmailUtil::EMAIL_SUCCESS) { + $token->insert(); + } else { + print "Failed to send alert $data{alert_id}!"; + } +} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/Comment.pm b/perllib/FixMyStreet/DB/ResultSet/Comment.pm new file mode 100644 index 000000000..70f8027aa --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/Comment.pm @@ -0,0 +1,41 @@ +package FixMyStreet::DB::ResultSet::Comment; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + +sub timeline { + my ( $rs, $restriction ) = @_; + + my $prefetch = + FixMyStreet::App->model('DB')->schema->storage->sql_maker->quote_char ? + [ qw/user/ ] : + []; + + return $rs->search( + { + state => 'confirmed', + created => { '>=', \"ms_current_timestamp()-'7 days'::interval" }, + %{ $restriction }, + }, + { + prefetch => $prefetch, + } + ); +} + +sub summary_count { + my ( $rs, $restriction ) = @_; + + return $rs->search( + $restriction, + { + group_by => ['me.state'], + select => [ 'me.state', { count => 'me.id' } ], + as => [qw/state state_count/], + join => 'problem' + } + ); +} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/Contact.pm b/perllib/FixMyStreet/DB/ResultSet/Contact.pm new file mode 100644 index 000000000..6fa6a03a0 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/Contact.pm @@ -0,0 +1,33 @@ +package FixMyStreet::DB::ResultSet::Contact; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + +=head2 not_deleted + + $rs = $rs->not_deleted(); + +Filter down to not deleted contacts - which have C<deleted> set to false; + +=cut + +sub not_deleted { + my $rs = shift; + return $rs->search( { deleted => 0 } ); +} + +sub summary_count { + my ( $rs, $restriction ) = @_; + + return $rs->search( + $restriction, + { + group_by => ['confirmed'], + select => [ 'confirmed', { count => 'id' } ], + as => [qw/confirmed confirmed_count/] + } + ); +} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/Nearby.pm b/perllib/FixMyStreet/DB/ResultSet/Nearby.pm new file mode 100644 index 000000000..3b3a3d90b --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/Nearby.pm @@ -0,0 +1,50 @@ +package FixMyStreet::DB::ResultSet::Nearby; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + +sub nearby { + my ( $rs, $c, $dist, $ids, $limit, $mid_lat, $mid_lon, $interval ) = @_; + + my $params = { + state => [ 'confirmed', 'fixed' ], + }; + $params->{'current_timestamp-lastupdate'} = { '<', \"'$interval'::interval" } + if $interval; + $params->{id} = { -not_in => $ids } + if $ids; + $params = { + %{ $c->cobrand->problems_clause }, + %$params + } if $c->cobrand->problems_clause; + + my $attrs = { + join => 'problem', + columns => [ + 'problem.id', 'problem.title', 'problem.latitude', + 'problem.longitude', 'distance', 'problem.state', + 'problem.confirmed' + ], + bind => [ $mid_lat, $mid_lon, $dist ], + order_by => [ 'distance', { -desc => 'created' } ], + rows => $limit, + }; + + my @problems = mySociety::Locale::in_gb_locale { $rs->search( $params, $attrs )->all }; + return \@problems; +} + +# XXX Not currently used, so not migrating at present. +#sub fixed_nearby { +# my ($dist, $mid_lat, $mid_lon) = @_; +# mySociety::Locale::in_gb_locale { select_all( +# "select id, title, latitude, longitude, distance +# from problem_find_nearby(?, ?, $dist) as nearby, problem +# where nearby.problem_id = problem.id and state='fixed' +# site_restriction +# order by lastupdate desc", $mid_lat, $mid_lon); +# } +#} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/Problem.pm b/perllib/FixMyStreet/DB/ResultSet/Problem.pm new file mode 100644 index 000000000..ca329ab59 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/Problem.pm @@ -0,0 +1,203 @@ +package FixMyStreet::DB::ResultSet::Problem; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + +my $site_restriction; +my $site_key; + +sub set_restriction { + my ( $rs, $sql, $key, $restriction ) = @_; + $site_key = $key; + $site_restriction = $restriction; +} + +# Front page statistics + +sub recent_fixed { + my $rs = shift; + my $key = "recent_fixed:$site_key"; + my $result = Memcached::get($key); + unless ($result) { + $result = $rs->search( { + state => 'fixed', + lastupdate => { '>', \"current_timestamp-'1 month'::interval" }, + } )->count; + Memcached::set($key, $result, 3600); + } + return $result; +} + +sub number_comments { + my $rs = shift; + my $key = "number_comments:$site_key"; + my $result = Memcached::get($key); + unless ($result) { + $result = $rs->search( + { 'comments.state' => 'confirmed' }, + { join => 'comments' } + )->count; + Memcached::set($key, $result, 3600); + } + return $result; +} + +sub recent_new { + my ( $rs, $interval ) = @_; + (my $key = $interval) =~ s/\s+//g; + $key = "recent_new:$site_key:$key"; + my $result = Memcached::get($key); + unless ($result) { + $result = $rs->search( { + state => [ 'confirmed', 'fixed' ], + confirmed => { '>', \"current_timestamp-'$interval'::interval" }, + } )->count; + Memcached::set($key, $result, 3600); + } + return $result; +} + +# Front page recent lists + +sub recent { + my ( $rs ) = @_; + my $key = "recent:$site_key"; + my $result = Memcached::get($key); + unless ($result) { + $result = [ $rs->search( { + state => [ 'confirmed', 'fixed' ] + }, { + columns => [ 'id', 'title' ], + order_by => { -desc => 'confirmed' }, + rows => 5, + } )->all ]; + Memcached::set($key, $result, 3600); + } + return $result; +} + +sub recent_photos { + my ( $rs, $num, $lat, $lon, $dist ) = @_; + my $probs; + my $query = { + state => [ 'confirmed', 'fixed' ], + photo => { '!=', undef }, + }; + my $attrs = { + columns => [ 'id', 'title' ], + order_by => { -desc => 'confirmed' }, + rows => $num, + }; + if (defined $lat) { + my $dist2 = $dist; # Create a copy of the variable to stop it being stringified into a locale in the next line! + my $key = "recent_photos:$site_key:$num:$lat:$lon:$dist2"; + $probs = Memcached::get($key); + unless ($probs) { + $attrs->{bind} = [ $lat, $lon, $dist ]; + $attrs->{join} = 'nearby'; + $probs = [ mySociety::Locale::in_gb_locale { + $rs->search( $query, $attrs )->all; + } ]; + Memcached::set($key, $probs, 3600); + } + } else { + my $key = "recent_photos:$site_key:$num"; + $probs = Memcached::get($key); + unless ($probs) { + $probs = [ $rs->search( $query, $attrs )->all ]; + Memcached::set($key, $probs, 3600); + } + } + return $probs; +} + +# Problems around a location + +sub around_map { + my ( $rs, $min_lat, $max_lat, $min_lon, $max_lon, $interval, $limit ) = @_; + my $attr = { + order_by => { -desc => 'created' }, + columns => [ + 'id', 'title' ,'latitude', 'longitude', 'state', 'confirmed' + ], + }; + $attr->{rows} = $limit if $limit; + + my $q = { + state => [ 'confirmed', 'fixed' ], + latitude => { '>=', $min_lat, '<', $max_lat }, + longitude => { '>=', $min_lon, '<', $max_lon }, + }; + $q->{'current_timestamp - lastupdate'} = { '<', \"'$interval'::interval" } + if $interval; + + my @problems = mySociety::Locale::in_gb_locale { $rs->search( $q, $attr )->all }; + return \@problems; +} + +# Admin functions + +sub timeline { + my ( $rs ) = @_; + + my $prefetch = + FixMyStreet::App->model('DB')->schema->storage->sql_maker->quote_char ? + [ qw/user/ ] : + []; + + return $rs->search( + { + -or => { + created => { '>=', \"ms_current_timestamp()-'7 days'::interval" }, + confirmed => { '>=', \"ms_current_timestamp()-'7 days'::interval" }, + whensent => { '>=', \"ms_current_timestamp()-'7 days'::interval" }, + } + }, + { + prefetch => $prefetch, + } + ); +} + +sub summary_count { + my ( $rs ) = @_; + + return $rs->search( + undef, + { + group_by => ['state'], + select => [ 'state', { count => 'id' } ], + as => [qw/state state_count/] + } + ); +} + +sub unique_users { + my ( $rs ) = @_; + + return $rs->search( { + state => [ 'confirmed', 'fixed' ], + }, { + select => [ { count => { distinct => 'user_id' } } ], + as => [ 'count' ] + } )->first->get_column('count'); +} + +sub categories_summary { + my ( $rs ) = @_; + + my $categories = $rs->search( { + state => [ 'confirmed', 'fixed' ], + whensent => { '<' => \"NOW() - INTERVAL '4 weeks'" }, + }, { + select => [ 'category', { count => 'id' }, { count => \"case when state='fixed' then 1 else null end" } ], + as => [ 'category', 'c', 'fixed' ], + group_by => [ 'category' ], + result_class => 'DBIx::Class::ResultClass::HashRefInflator' + } ); + my %categories = map { $_->{category} => { total => $_->{c}, fixed => $_->{fixed} } } $categories->all; + return \%categories; +} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/Questionnaire.pm b/perllib/FixMyStreet/DB/ResultSet/Questionnaire.pm new file mode 100644 index 000000000..e490c77a6 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/Questionnaire.pm @@ -0,0 +1,149 @@ +package FixMyStreet::DB::ResultSet::Questionnaire; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; +use File::Slurp; +use Utils; +use mySociety::EmailUtil; + +sub send_questionnaires { + my ( $rs, $params ) = @_; + $rs->send_questionnaires_period( '4 weeks', $params ); + $rs->send_questionnaires_period( '26 weeks', $params ) + if $params->{site} eq 'emptyhomes'; +} + +sub send_questionnaires_period { + my ( $rs, $period, $params ) = @_; + + # Select all problems that need a questionnaire email sending + my $q_params = { + state => [ 'confirmed', 'fixed' ], + whensent => [ + '-and', + { '!=', undef }, + { '<', \"ms_current_timestamp() - '$period'::interval" }, + ], + send_questionnaire => 1, + }; + # FIXME Do these a bit better... + if ($params->{site} eq 'emptyhomes' && $period eq '4 weeks') { + $q_params->{'(select max(whensent) from questionnaire where me.id=problem_id)'} = undef; + } elsif ($params->{site} eq 'emptyhomes' && $period eq '26 weeks') { + $q_params->{'(select max(whensent) from questionnaire where me.id=problem_id)'} = { '!=', undef }; + } else { + $q_params->{'-or'} = [ + '(select max(whensent) from questionnaire where me.id=problem_id)' => undef, + '(select max(whenanswered) from questionnaire where me.id=problem_id)' => { '<', \"ms_current_timestamp() - '$period'::interval" } + ]; + } + + my $unsent = FixMyStreet::App->model('DB::Problem')->search( $q_params, { + order_by => { -desc => 'confirmed' } + } ); + + while (my $row = $unsent->next) { + + my $cobrand = FixMyStreet::Cobrand->get_class_for_moniker($row->cobrand)->new(); + $cobrand->set_lang_and_domain($row->lang, 1); + + # Cobranded and non-cobranded messages can share a database. In this case, the conf file + # should specify a vhost to send the reports for each cobrand, so that they don't get sent + # more than once if there are multiple vhosts running off the same database. The email_host + # call checks if this is the host that sends mail for this cobrand. + next unless $cobrand->email_host; + + my $template; + if ($params->{site} eq 'emptyhomes') { + ($template = $period) =~ s/ //; + $template = File::Slurp::read_file( FixMyStreet->path_to( "templates/email/emptyhomes/" . $row->lang . "/questionnaire-$template.txt" )->stringify ); + } else { + $template = FixMyStreet->path_to( "templates", "email", $cobrand->moniker, "questionnaire.txt" )->stringify; + $template = FixMyStreet->path_to( "templates", "email", "default", "questionnaire.txt" )->stringify + unless -e $template; + $template = File::Slurp::read_file( $template ); + } + + my %h = map { $_ => $row->$_ } qw/name title detail category/; + $h{created} = Utils::prettify_duration( time() - $row->confirmed->epoch, 'week' ); + + my $questionnaire = FixMyStreet::App->model('DB::Questionnaire')->create( { + problem_id => $row->id, + whensent => \'ms_current_timestamp()', + } ); + + # We won't send another questionnaire unless they ask for it (or it was + # the first EHA questionnaire. + $row->send_questionnaire( 0 ) + if $params->{site} ne 'emptyhomes' || $period eq '26 weeks'; + + my $token = FixMyStreet::App->model("DB::Token")->new_result( { + scope => 'questionnaire', + data => $questionnaire->id, + } ); + $h{url} = $cobrand->base_url_for_emails($row->cobrand_data) . '/Q/' . $token->token; + + my $sender = $cobrand->contact_email; + my $sender_name = _($cobrand->contact_name); + $sender =~ s/team/fms-DO-NOT-REPLY/; + + print "Sending questionnaire " . $questionnaire->id . ", problem " + . $row->id . ", token " . $token->token . " to " + . $row->user->email . "\n" + if $params->{verbose}; + + my $result = FixMyStreet::App->send_email_cron( + { + _template_ => $template, + _parameters_ => \%h, + To => [ [ $row->user->email, $row->name ] ], + From => [ $sender, $sender_name ], + }, + $sender, + [ $row->user->email ], + $params->{nomail} + ); + if ($result == mySociety::EmailUtil::EMAIL_SUCCESS) { + print " ...success\n" if $params->{verbose}; + $row->update(); + $token->insert(); + } else { + print " ...failed\n" if $params->{verbose}; + $questionnaire->delete; + } + } +} + +sub timeline { + my ( $rs, $restriction ) = @_; + + return $rs->search( + { + -or => { + whenanswered => { '>=', \"ms_current_timestamp()-'7 days'::interval" }, + 'me.whensent' => { '>=', \"ms_current_timestamp()-'7 days'::interval" }, + }, + %{ $restriction }, + }, + { + -select => [qw/me.*/], + prefetch => [qw/problem/], + } + ); +} + +sub summary_count { + my ( $rs, $restriction ) = @_; + + return $rs->search( + $restriction, + { + group_by => [ \'whenanswered is not null' ], + select => [ \'(whenanswered is not null)', { count => 'me.id' } ], + as => [qw/answered questionnaire_count/], + join => 'problem' + } + ); +} +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/User.pm b/perllib/FixMyStreet/DB/ResultSet/User.pm new file mode 100644 index 000000000..7e657a936 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/User.pm @@ -0,0 +1,8 @@ +package FixMyStreet::DB::ResultSet::User; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + + +1; diff --git a/perllib/FixMyStreet/Geocode.pm b/perllib/FixMyStreet/Geocode.pm index c06c3bb55..4ae3df368 100644 --- a/perllib/FixMyStreet/Geocode.pm +++ b/perllib/FixMyStreet/Geocode.pm @@ -9,172 +9,40 @@ package FixMyStreet::Geocode; use strict; -use Encode; -use Error qw(:try); -use File::Slurp; -use File::Path (); -use LWP::Simple; -use Digest::MD5 qw(md5_hex); use URI::Escape; +use FixMyStreet::Geocode::Bing; +use FixMyStreet::Geocode::Google; -use Cobrand; -use Page; -use Utils; -use mySociety::Config; -use mySociety::Locale; -use mySociety::MaPit; -use mySociety::PostcodeUtil; -use mySociety::Web qw(NewURL); - -BEGIN { - (my $dir = __FILE__) =~ s{/[^/]*?$}{}; - mySociety::Config::set_file("$dir/../../conf/general"); -} - -# lookup STRING QUERY +# lookup STRING CONTEXT # Given a user-inputted string, try and convert it into co-ordinates using either -# MaPit if it's a postcode, or Google Maps API otherwise. Returns an array of -# data, including an error if there is one (which includes a location being in +# MaPit if it's a postcode, or some web API otherwise. Returns an array of +# data, including an error if there is one (which includes a location being in # Northern Ireland). The information in the query may be used by cobranded versions # of the site to diambiguate locations. sub lookup { - my ($s, $q) = @_; - my ($latitude, $longitude, $error); - if (mySociety::Config::get('COUNTRY') eq 'GB') { - if ($s =~ /^\d+$/) { - $error = 'FixMyStreet is a UK-based website that currently works in England, Scotland, and Wales. Please enter either a postcode, or a Great British street name and area.'; - } elsif (mySociety::PostcodeUtil::is_valid_postcode($s)) { - my $location = mySociety::MaPit::call('postcode', $s); - unless ($error = Page::mapit_check_error($location)) { - $latitude = $location->{wgs84_lat}; - $longitude = $location->{wgs84_lon}; - } - } - } elsif (mySociety::Config::get('COUNTRY') eq 'NO') { - if ($s =~ /^\d{4}$/) { - my $location = mySociety::MaPit::call('postcode', $s); - unless ($error = Page::mapit_check_error($location)) { - $latitude = $location->{wgs84_lat}; - $longitude = $location->{wgs84_lon}; - } - } - } - unless ($error || defined $latitude) { - ($latitude, $longitude, $error) = FixMyStreet::Geocode::string($s, $q); - } - return ($latitude, $longitude, $error); -} - -sub geocoded_string_coordinates { - my ($js, $q) = @_; - my ($latitude, $longitude, $error); - my ($accuracy) = $js =~ /"Accuracy" *: *(\d)/; - if ($accuracy < 4) { - $error = _('Sorry, that location appears to be too general; please be more specific.'); - } elsif ( $js =~ /"coordinates" *: *\[ *(.*?), *(.*?),/ ) { - $longitude = $1; - $latitude = $2; - if (mySociety::Config::get('COUNTRY') eq 'GB') { - try { - my ($easting, $northing) = Utils::convert_latlon_to_en( $latitude, $longitude ); - } catch Error::Simple with { - mySociety::Locale::pop(); # We threw exception, so it won't have happened. - $error = shift; - $error = _('That location does not appear to be in Britain; please try again.') - if $error =~ /out of the area covered/; - } - } - } - return ($latitude, $longitude, $error); + my ($s, $c) = @_; + my $data = $c->cobrand->geocode_postcode($s); + $data = string($s, $c) + unless $data->{error} || defined $data->{latitude}; + $data->{error} = _('Sorry, we could not find that location.') + unless $data->{error} || defined $data->{latitude}; + return ( $data->{latitude}, $data->{longitude}, $data->{error} ); } -sub results_check { - my $q = shift; - my ($error, @valid_locations); - foreach (@_) { - next unless /"address" *: *"(.*?)"/s; - my $address = $1; - next unless Cobrand::geocoded_string_check(Page::get_cobrand($q), $address, $q); - next if $address =~ /BT\d/; - push (@$error, $address); - push (@valid_locations, $_); - } - if (scalar @valid_locations == 1) { - return geocoded_string_coordinates($valid_locations[0], $q); - } - $error = _('Sorry, we could not find that location.') unless $error; - return (undef, undef, $error); -} - -# string STRING QUERY -# Canonicalises, looks up on Google Maps API, and caches, a user-inputted location. -# Returns array of (LAT, LON, ERROR), where ERROR is either undef, a string, or -# an array of matches if there are more than one. The information in the query -# may be used to disambiguate the location in cobranded versions of the site. +# string STRING CONTEXT +# Canonicalises, and then passes to some external API to look stuff up. sub string { - my ($s, $q) = @_; + my ($s, $c) = @_; $s = lc($s); $s =~ s/[^-&\w ']/ /g; $s =~ s/\s+/ /g; $s = URI::Escape::uri_escape_utf8($s); - $s = Cobrand::disambiguate_location(Page::get_cobrand($q), "q=$s", $q); $s =~ s/%20/+/g; - my $url = 'http://maps.google.com/maps/geo?' . $s; - my $cache_dir = mySociety::Config::get('GEO_CACHE'); - my $cache_file = $cache_dir . md5_hex($url); - my ($js, $error); - if (-s $cache_file) { - $js = File::Slurp::read_file($cache_file); - } else { - $url .= ',+UK' unless $url =~ /united\++kingdom$/ || $url =~ /uk$/i - || mySociety::Config::get('COUNTRY') ne 'GB'; - $url .= '&sensor=false&key=' . mySociety::Config::get('GOOGLE_MAPS_API_KEY'); - $js = LWP::Simple::get($url); - $js = encode_utf8($js) if utf8::is_utf8($js); - File::Path::mkpath($cache_dir); - File::Slurp::write_file($cache_file, $js) if $js && $js !~ /"code":6[12]0/; - } - if (!$js) { - $error = _('Sorry, we could not parse that location. Please try again.'); - } elsif ($js !~ /"code" *: *200/) { - $error = _('Sorry, we could not find that location.'); - } elsif ($js =~ /}, *{/) { # Multiple - return results_check($q, (split /}, *{/, $js)); - } elsif ($js =~ /BT\d/) { - # Northern Ireland, hopefully - $error = _("We do not cover Northern Ireland, I'm afraid, as our licence doesn't include any maps for the region."); - } else { - return results_check($q, $js); - } - return (undef, undef, $error); -} - -# list_choices -# Prints response if there's more than one possible result -sub list_choices { - my ($choices, $page, $q) = @_; - my $url; - my $cobrand = Page::get_cobrand($q); - my $message = _('We found more than one match for that location. We show up to ten matches, please try a different search if yours is not here.'); - my $out = '<p>' . $message . '</p>'; - my $choice_list = '<ul>'; - foreach my $choice (@$choices) { - $choice = decode_utf8($choice); - $choice =~ s/, United Kingdom//; - $choice =~ s/, UK//; - $url = Cobrand::url($cobrand, NewURL($q, -retain => 1, -url => $page, 'pc' => $choice), $q); - $url =~ s/%20/+/g; - $choice_list .= '<li><a href="' . $url . '">' . $choice . "</a></li>\n"; - } - $choice_list .= '</ul>'; - $out .= $choice_list; - my %vars = (message => $message, - choice_list => $choice_list, - header => _('More than one match'), - url_home => Cobrand::url($cobrand, '/', $q)); - my $cobrand_choice = Page::template_include('geocode-choice', $q, Page::template_root($q), %vars); - return $cobrand_choice if $cobrand_choice; - return $out; + my $params = $c->cobrand->disambiguate_location(); + return FixMyStreet::Geocode::Bing::string($s, $c, $params) + if FixMyStreet->config('BING_MAPS_API_KEY'); + return FixMyStreet::Geocode::Google::string($s, $c, $params) + if FixMyStreet->config('GOOGLE_MAPS_API_KEY'); } 1; diff --git a/perllib/FixMyStreet/Geocode/Bing.pm b/perllib/FixMyStreet/Geocode/Bing.pm new file mode 100644 index 000000000..cfeffc856 --- /dev/null +++ b/perllib/FixMyStreet/Geocode/Bing.pm @@ -0,0 +1,67 @@ +#!/usr/bin/perl +# +# FixMyStreet::Geocode::Bing +# Geocoding with Bing for FixMyStreet. +# +# Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. +# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ + +package FixMyStreet::Geocode::Bing; + +use strict; +use Encode; +use File::Slurp; +use File::Path (); +use LWP::Simple; +use Digest::MD5 qw(md5_hex); + +# string STRING CONTEXT +# Looks up on Bing Maps API, and caches, a user-inputted location. +# Returns array of (LAT, LON, ERROR), where ERROR is either undef, a string, or +# an array of matches if there are more than one. The information in the query +# may be used to disambiguate the location in cobranded versions of the site. +sub string { + my ( $s, $c, $params ) = @_; + my $url = "http://dev.virtualearth.net/REST/v1/Locations?q=$s&c=en-GB"; # FIXME nb-NO for Norway + $url .= '&mapView=' . $params->{bounds}[0] . ',' . $params->{bounds}[1] + if $params->{bounds}; + $url .= '&userLocation=' . $params->{centre} if $params->{centre}; + + my $cache_dir = FixMyStreet->config('GEO_CACHE') . 'bing/'; + my $cache_file = $cache_dir . md5_hex($url); + my $js; + if (-s $cache_file) { + $js = File::Slurp::read_file($cache_file); + } else { + $url .= '&key=' . FixMyStreet->config('BING_MAPS_API_KEY'); + $js = LWP::Simple::get($url); + $js = encode_utf8($js) if utf8::is_utf8($js); + File::Path::mkpath($cache_dir); + File::Slurp::write_file($cache_file, $js) if $js; + } + + if (!$js) { + return { error => _('Sorry, we could not parse that location. Please try again.') }; + } elsif ($js =~ /BT\d/) { + return { error => _("We do not cover Northern Ireland, I'm afraid, as our licence doesn't include any maps for the region.") }; + } + + $js = JSON->new->utf8->allow_nonref->decode($js); + if ($js->{statusCode} ne '200') { + return { error => _('Sorry, we could not find that location.') }; + } + + my $results = $js->{resourceSets}->[0]->{resources}; + my ( $error, @valid_locations, $latitude, $longitude ); + foreach (@$results) { + my $address = $_->{name}; + next unless $_->{address}->{countryRegion} eq 'United Kingdom'; # FIXME This is UK only + ( $latitude, $longitude ) = @{ $_->{point}->{coordinates} }; + push (@$error, $address); + push (@valid_locations, $_); + } + return { latitude => $latitude, longitude => $longitude } if scalar @valid_locations == 1; + return { error => $error }; +} + +1; diff --git a/perllib/FixMyStreet/Geocode/Google.pm b/perllib/FixMyStreet/Geocode/Google.pm new file mode 100644 index 000000000..c37a750a2 --- /dev/null +++ b/perllib/FixMyStreet/Geocode/Google.pm @@ -0,0 +1,85 @@ +#!/usr/bin/perl +# +# FixMyStreet::Geocode +# The geocoding functions for FixMyStreet. +# +# Copyright (c) 2010 UK Citizens Online Democracy. All rights reserved. +# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ + +package FixMyStreet::Geocode::Google; + +use strict; +use Encode; +use File::Slurp; +use File::Path (); +use LWP::Simple; +use Digest::MD5 qw(md5_hex); + +# string STRING CONTEXT +# Looks up on Google Maps API, and caches, a user-inputted location. +# Returns array of (LAT, LON, ERROR), where ERROR is either undef, a string, or +# an array of matches if there are more than one. The information in the query +# may be used to disambiguate the location in cobranded versions of the site. +sub string { + my ( $s, $c, $params ) = @_; + + my $url = 'http://maps.google.com/maps/geo?q=' . $s; + $url .= '&ll=' . $params->{centre} if $params->{centre}; + $url .= '&spn=' . $params->{span} if $params->{span}; + $url .= '&gl=' . $params->{country} if $params->{country}; + $url .= '&hl=' . $params->{lang} if $params->{lang}; + + my $cache_dir = FixMyStreet->config('GEO_CACHE') . 'google/'; + my $cache_file = $cache_dir . md5_hex($url); + my $js; + if (-s $cache_file) { + $js = File::Slurp::read_file($cache_file); + } else { + # For some reason adding gl=uk is no longer sufficient to make google + # think we are in the UK for some locations so we explictly add UK to + # the address. We do it here so as not to invalidate existing cache + # entries + if ( $c->cobrand->country eq 'GB' + && $url !~ /,\+UK/ + && $url !~ /united\++kingdom$/ ) + { + if ( $url =~ /&/ ) { + $url =~ s/&/,+UK&/; + } else { + $url .= ',+UK'; + } + } + $url .= '&sensor=false&key=' . FixMyStreet->config('GOOGLE_MAPS_API_KEY'); + $js = LWP::Simple::get($url); + $js = encode_utf8($js) if utf8::is_utf8($js); + File::Path::mkpath($cache_dir); + File::Slurp::write_file($cache_file, $js) if $js && $js !~ /"code":6[12]0/; + } + + if (!$js) { + return { error => _('Sorry, we could not parse that location. Please try again.') }; + } elsif ($js =~ /BT\d/) { + # Northern Ireland, hopefully + return { error => _("We do not currently cover Northern Ireland, I'm afraid.") }; + } + + $js = JSON->new->utf8->allow_nonref->decode($js); + if ($js->{Status}->{code} ne '200') { + return { error => _('Sorry, we could not find that location.') }; + } + + my $results = $js->{Placemark}; + my ( $error, @valid_locations, $latitude, $longitude ); + foreach (@$results) { + next unless $_->{AddressDetails}->{Accuracy} >= 4; + my $address = $_->{address}; + next unless $c->cobrand->geocoded_string_check( $address ); + ( $longitude, $latitude ) = @{ $_->{Point}->{coordinates} }; + push (@$error, $address); + push (@valid_locations, $_); + } + return { latitude => $latitude, longitude => $longitude } if scalar @valid_locations == 1; + return { error => $error }; +} + +1; diff --git a/perllib/FixMyStreet/Geocode/OSM.pm b/perllib/FixMyStreet/Geocode/OSM.pm new file mode 100644 index 000000000..b1becaa7a --- /dev/null +++ b/perllib/FixMyStreet/Geocode/OSM.pm @@ -0,0 +1,116 @@ +#!/usr/bin/perl +# +# FixMyStreet:Geocode::OSM +# OpenStreetmap forward and reverse geocoding for FixMyStreet. +# +# Copyright (c) 2011 Petter Reinholdtsen. Some rights reserved. +# Email: pere@hungry.com + +package FixMyStreet::Geocode::OSM; + +use warnings; +use strict; + +use Memcached; +use mySociety::Config; +use LWP::Simple; +use XML::Simple; + +my $osmapibase = "http://www.openstreetmap.org/api/"; +my $nominatimbase = "http://nominatim.openstreetmap.org/"; + + +sub lookup_location { + my ($latitude, $longitude, $zoom) = @_; + my $url = + "${nominatimbase}reverse?format=xml&zoom=$zoom&lat=$latitude&lon=$longitude"; + my $key = "OSM:lookup_location:$url"; + my $result = Memcached::get($key); + unless ($result) { + my $j = LWP::Simple::get($url); + if ($j) { + Memcached::set($key, $j, 3600); + my $ref = XMLin($j); + return $ref; + } else { + print STDERR "No reply from $url\n"; + } + return undef; + } + return XMLin($result); +} + +sub _osmxml_to_hash { + my ($xml, $type) = @_; + my $ref = XMLin($xml); + my %tags; + if ('ARRAY' eq ref $ref->{$type}->{tag}) { + map { $tags{$_->{'k'}} = $_->{'v'} } @{$ref->{$type}->{tag}}; + return \%tags; + } else { + return undef; + } +} + +sub get_object_tags { + my ($type, $id) = @_; + my $url = "${osmapibase}0.6/$type/$id"; + my $key = "OSM:get_object_tags:$url"; + my $result = Memcached::get($key); + unless ($result) { + my $j = LWP::Simple::get($url); + if ($j) { + Memcached::set($key, $j, 3600); + return _osmxml_to_hash($j, $type); + } else { + print STDERR "No reply from $url\n"; + } + return undef; + } + return _osmxml_to_hash($result, $type); +} + +# A better alternative might be +# http://www.geonames.org/maps/osm-reverse-geocoder.html#findNearbyStreetsOSM +sub get_nearest_road_tags { + my ( $cobrand, $latitude, $longitude ) = @_; + my $inforef = lookup_location($latitude, $longitude, 16); + if (exists $inforef->{result}->{osm_type} + && 'way' eq $inforef->{result}->{osm_type}) { + my $osmtags = get_object_tags('way', + $inforef->{result}->{osm_id}); + unless ( exists $osmtags->{operator} ) { + $osmtags->{operatorguess} = $cobrand->guess_road_operator( $osmtags ); + } + return $osmtags; + } + return undef; +} + +sub closest_road_text { + my ( $cobrand, $latitude, $longitude ) = @_; + my $str = ''; + my $osmtags = get_nearest_road_tags( $cobrand, $latitude, $longitude ); + if ($osmtags) { + my ($name, $ref) = ('',''); + $name = $osmtags->{name} if exists $osmtags->{name}; + $ref = " ($osmtags->{ref})" if exists $osmtags->{ref}; + if ($name || $ref) { + $str .= _('The following information about the nearest road might be inaccurate or irrelevant, if the problem is close to several roads or close to a road without a name registered in OpenStreetMap.') . "\n\n"; + $str .= sprintf(_("Nearest named road to the pin placed on the map (automatically generated using OpenStreetMap): %s%s"), + $name, $ref) . "\n\n"; + + if (my $operator = $osmtags->{operator}) { + $str .= sprintf(_("Road operator for this named road (from OpenStreetMap): %s"), + $operator) . "\n\n"; + } elsif ($operator = $osmtags->{operatorguess}) { + $str .= sprintf(_("Road operator for this named road (derived from road reference number and type): %s"), + $operator) . "\n\n"; + } + } + } + return $str; +} + +1; + diff --git a/perllib/FixMyStreet/Map.pm b/perllib/FixMyStreet/Map.pm index 5305b360a..825e1cd19 100644 --- a/perllib/FixMyStreet/Map.pm +++ b/perllib/FixMyStreet/Map.pm @@ -13,18 +13,16 @@ use strict; use Module::Pluggable sub_name => 'maps', search_path => __PACKAGE__, - except => 'FixMyStreet::Map::Tilma::Original', require => 1; # Get the list of maps we want and load map classes at compile time my @ALL_MAP_CLASSES = allowed_maps(); -use Problems; -use Cobrand; use mySociety::Config; use mySociety::Gaze; use mySociety::Locale; use mySociety::Web qw(ent); +use Utils; =head2 allowed_maps @@ -63,55 +61,43 @@ sub display_map { return $map_class->display_map(@_); } -sub display_map_end { - my ($type) = @_; - my $out = '</div>'; - $out .= '</form>' if ($type); - return $out; -} - -sub header { - my ( $q, $type ) = @_; - return '' unless $type; - - my $cobrand = Page::get_cobrand($q); - my $cobrand_form_elements = - Cobrand::form_elements( $cobrand, 'mapForm', $q ); - my $form_action = Cobrand::url( $cobrand, '/', $q ); - my $encoding = ''; - $encoding = ' enctype="multipart/form-data"' if $type == 2; - my $pc = ent($q->param('pc') || ''); - my $map = ent($q->param('map') || ''); - return <<EOF; -<form action="$form_action" method="post" name="mapForm" id="mapForm"$encoding> -<input type="hidden" name="submit_map" value="1"> -<input type="hidden" name="map" value="$map"> -<input type="hidden" name="pc" value="$pc"> -$cobrand_form_elements -EOF -} - sub map_features { - my ( $q, $lat, $lon, $interval ) = @_; + my ( $c, $lat, $lon, $interval ) = @_; # TODO - be smarter about calculating the surrounding square # use deltas that are roughly 500m in the UK - so we get a 1 sq km search box my $lat_delta = 0.00438; my $lon_delta = 0.00736; + return _map_features( + $c, $lat, $lon, + $lon - $lon_delta, $lat - $lat_delta, + $lon + $lon_delta, $lat + $lat_delta, + $interval + ); +} - my $min_lat = $lat - $lat_delta; - my $max_lat = $lat + $lat_delta; +sub map_features_bounds { + my ( $c, $min_lon, $min_lat, $max_lon, $max_lat, $interval ) = @_; + + my $lat = ( $max_lat + $min_lat ) / 2; + my $lon = ( $max_lon + $min_lon ) / 2; + return _map_features( + $c, $lat, $lon, + $min_lon, $min_lat, + $max_lon, $max_lat, + $interval + ); +} - my $min_lon = $lon - $lon_delta; - my $max_lon = $lon + $lon_delta; +sub _map_features { + my ( $c, $lat, $lon, $min_lon, $min_lat, $max_lon, $max_lat, $interval ) = @_; # list of problems around map can be limited, but should show all pins - my $around_limit # - = Cobrand::on_map_list_limit( Page::get_cobrand($q) ) || undef; + my $around_limit = $c->cobrand->on_map_list_limit || undef; my @around_args = ( $min_lat, $max_lat, $min_lon, $max_lon, $interval ); - my $around_map_list = Problems::around_map( @around_args, $around_limit ); - my $around_map = Problems::around_map( @around_args, undef ); + my $around_map_list = $c->cobrand->problems->around_map( @around_args, $around_limit ); + my $around_map = $c->cobrand->problems->around_map( @around_args, undef ); my $dist; mySociety::Locale::in_gb_locale { @@ -122,9 +108,10 @@ sub map_features { $dist = int( $dist * 10 + 0.5 ) / 10; my $limit = 20; - my @ids = map { $_->{id} } @$around_map_list; - my $nearby = Problems::nearby( $dist, join( ',', @ids ), - $limit, $lat, $lon, $interval ); + my @ids = map { $_->id } @$around_map_list; + my $nearby = $c->model('DB::Nearby')->nearby( + $c, $dist, \@ids, $limit, $lat, $lon, $interval + ); return ( $around_map, $around_map_list, $nearby, $dist ); } @@ -137,8 +124,19 @@ sub click_to_wgs84 { return $map_class->click_to_wgs84(@_); } +=head2 tile_xy_to_wgs84 + +Takes the tile x,y and converts to lat, lon. Legacy to deal with old URLs, +hence hard-coded things. + +=cut + sub tile_xy_to_wgs84 { - return $map_class->tile_xy_to_wgs84(@_); + my ( $x, $y ) = @_; + my $easting = int( $x * (5000/31) + 0.5 ); + my $northing = int( $y * (5000/31) + 0.5 ); + my ( $lat, $lon ) = Utils::convert_en_to_latlon( $easting, $northing ); + return ( $lat, $lon ); } 1; diff --git a/perllib/FixMyStreet/Map/Bing.pm b/perllib/FixMyStreet/Map/Bing.pm index 335759b08..54979eba1 100644 --- a/perllib/FixMyStreet/Map/Bing.pm +++ b/perllib/FixMyStreet/Map/Bing.pm @@ -11,55 +11,18 @@ package FixMyStreet::Map::Bing; use strict; use mySociety::Web qw(ent); -sub header_js { - return ' -<script type="text/javascript" src="http://ecn.dev.virtualearth.net/mapcontrol/mapcontrol.ashx?v=7.0&mkt=en-GB"></script> -<script type="text/javascript" src="/js/map-bing.js"></script> -'; -} - -# display_map Q PARAMS +# display_map C PARAMS # PARAMS include: -# EASTING, NORTHING for the centre point of the map -# TYPE is 1 if the map is clickable, 2 if clickable and has a form upload, -# 0 if not clickable +# latitude, longitude for the centre point of the map +# CLICKABLE is set if the map is clickable # PINS is array of pins to show, location and colour -# PRE/POST are HTML to show above/below map sub display_map { - my ($self, $q, %params) = @_; - $params{pre} ||= ''; - $params{post} ||= ''; - - my @pins; - foreach my $pin (@{$params{pins}}) { - $pin->[3] ||= ''; - push @pins, "[ $pin->[0], $pin->[1], '$pin->[2]', '$pin->[3]' ]"; - } - my $pins_js = join(",\n", @pins); - - my $out = FixMyStreet::Map::header($q, $params{type}); - my $copyright = _('Map contains Ordnance Survey data © Crown copyright and database right 2010.'); - my $key = mySociety::Config::get('BING_MAPS_API_KEY'); - $out .= <<EOF; -<input type="hidden" name="latitude" id="fixmystreet.latitude" value="$params{latitude}"> -<input type="hidden" name="longitude" id="fixmystreet.longitude" value="$params{longitude}"> -<script type="text/javascript"> -var fixmystreet = { - 'key': '$key', - 'latitude': $params{latitude}, - 'longitude': $params{longitude}, - 'pins': [ $pins_js ] -} -</script> -<div id="map_box"> - $params{pre} - <div id="map"></div> - <p id="copyright">$copyright</p> - $params{post} -</div> -<div id="side"> -EOF - return $out; + my ($self, $c, %params) = @_; + $c->stash->{map} = { + %params, + type => 'bing', + key => mySociety::Config::get('BING_MAPS_API_KEY'), + }; } 1; diff --git a/perllib/FixMyStreet/Map/BingOL.pm b/perllib/FixMyStreet/Map/BingOL.pm deleted file mode 100644 index 968642807..000000000 --- a/perllib/FixMyStreet/Map/BingOL.pm +++ /dev/null @@ -1,70 +0,0 @@ -#!/usr/bin/perl -# -# FixMyStreet:Map::BingOL -# Bing maps on FixMyStreet, using OpenLayers. -# -# Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ - -package FixMyStreet::Map::BingOL; - -use strict; -use mySociety::Gaze; -use mySociety::Web qw(ent); - -sub header_js { - return ' -<!-- <script type="text/javascript" src="http://ecn.dev.virtualearth.net/mapcontrol/mapcontrol.ashx?v=7.0&mkt=en-GB"></script> --> -<script type="text/javascript" src="/jslib/OpenLayers-2.10/OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-bing-ol.js"></script> -'; -} - -# display_map Q PARAMS -# PARAMS include: -# EASTING, NORTHING for the centre point of the map -# TYPE is 1 if the map is clickable, 2 if clickable and has a form upload, -# 0 if not clickable -# PINS is array of pins to show, location and colour -# PRE/POST are HTML to show above/below map -sub display_map { - my ($self, $q, %params) = @_; - $params{pre} ||= ''; - $params{post} ||= ''; - - my @pins; - foreach my $pin (@{$params{pins}}) { - $pin->[3] ||= ''; - push @pins, "[ $pin->[0], $pin->[1], '$pin->[2]', '$pin->[3]' ]"; - } - my $pins_js = join(",\n", @pins); - - my $out = FixMyStreet::Map::header($q, $params{type}); - my $copyright = _('Map contains Ordnance Survey data © Crown copyright and database right 2010. Microsoft'); - my $dist = mySociety::Gaze::get_radius_containing_population( $params{latitude}, $params{longitude}, 200_000 ); - my $zoom = 2; - $zoom = 3 if $dist < 10; - $out .= <<EOF; -<input type="hidden" name="latitude" id="fixmystreet.latitude" value="$params{latitude}"> -<input type="hidden" name="longitude" id="fixmystreet.longitude" value="$params{longitude}"> -<script type="text/javascript"> -var fixmystreet = { - 'latitude': $params{latitude}, - 'longitude': $params{longitude}, - 'zoom': $zoom, - 'pins': [ $pins_js ] -} -</script> -<div id="map_box"> - $params{pre} - <div id="map"></div> - <p id="copyright">$copyright</p> - $params{post} -</div> -<div id="side"> -EOF - return $out; -} - -1; diff --git a/perllib/FixMyStreet/Map/FMS.pm b/perllib/FixMyStreet/Map/FMS.pm new file mode 100644 index 000000000..2e40bfde3 --- /dev/null +++ b/perllib/FixMyStreet/Map/FMS.pm @@ -0,0 +1,59 @@ +#!/usr/bin/perl +# +# FixMyStreet:Map::FMS +# Bing and OS StreetView maps on FixMyStreet, using OpenLayers. +# +# Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. +# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ + +package FixMyStreet::Map::FMS; +use base 'FixMyStreet::Map::OSM'; + +use strict; + +# Is set by the JavaScript +sub map_type { + return '""'; +} + +sub map_template { + return 'fms'; +} + +sub copyright { + return _('Map contains Ordnance Survey data © Crown copyright and database right 2010.<br>© 2011 <a href="http://www.bing.com/maps/">Microsoft</a>. © AND, Navteq, Ordnance Survey.'); +} + +sub get_quadkey { + my ($x, $y, $z) = @_; + my $key = ''; + for (my $i = $z; $i > 0; $i--) { + my $digit = 0; + my $mask = 1 << ($i - 1); + $digit++ if ($x & $mask) != 0; + $digit += 2 if ($y & $mask) != 0; + $key .= $digit; + } + return $key; +} + +sub map_tiles { + my ($self, $x, $y, $z) = @_; + if ($z >= 16) { + return [ + "http://a.tilma.mysociety.org/sv/$z/" . ($x-1) . "/" . ($y-1) . ".png", + "http://b.tilma.mysociety.org/sv/$z/$x/" . ($y-1) . ".png", + "http://c.tilma.mysociety.org/sv/$z/" . ($x-1) . "/$y.png", + "http://tilma.mysociety.org/sv/$z/$x/$y.png", + ]; + } else { + return [ + "http://ecn.t0.tiles.virtualearth.net/tiles/r" . get_quadkey($x-1, $y-1, $z) . ".png?g=701&productSet=mmOS", + "http://ecn.t1.tiles.virtualearth.net/tiles/r" . get_quadkey($x, $y-1, $z) . ".png?g=701&productSet=mmOS", + "http://ecn.t2.tiles.virtualearth.net/tiles/r" . get_quadkey($x-1, $y, $z) . ".png?g=701&productSet=mmOS", + "http://ecn.t3.tiles.virtualearth.net/tiles/r" . get_quadkey($x, $y, $z) . ".png?g=701&productSet=mmOS", + ]; + } +} + +1; diff --git a/perllib/FixMyStreet/Map/Google.pm b/perllib/FixMyStreet/Map/Google.pm index 35896108b..ceb3a53ed 100644 --- a/perllib/FixMyStreet/Map/Google.pm +++ b/perllib/FixMyStreet/Map/Google.pm @@ -11,53 +11,17 @@ package FixMyStreet::Map::Google; use strict; use mySociety::Web qw(ent); -sub header_js { - return ' -<script type="text/javascript" src="http://maps.google.com/maps/api/js?sensor=false"></script> -<script type="text/javascript" src="/js/map-google.js"></script> -'; -} - -# display_map Q PARAMS +# display_map C PARAMS # PARAMS include: -# EASTING, NORTHING for the centre point of the map -# TYPE is 1 if the map is clickable, 2 if clickable and has a form upload, -# 0 if not clickable +# latitude, longitude for the centre point of the map +# CLICKABLE is set if the map is clickable # PINS is array of pins to show, location and colour -# PRE/POST are HTML to show above/below map sub display_map { - my ($self, $q, %params) = @_; - $params{pre} ||= ''; - $params{post} ||= ''; - - my @pins; - foreach my $pin (@{$params{pins}}) { - $pin->[3] ||= ''; - push @pins, "[ $pin->[0], $pin->[1], '$pin->[2]', '$pin->[3]' ]"; - } - my $pins_js = join(",\n", @pins); - - my $out = FixMyStreet::Map::header($q, $params{type}); - my $copyright = _('Map contains Ordnance Survey data © Crown copyright and database right 2010.'); - $out .= <<EOF; -<input type="hidden" name="latitude" id="fixmystreet.latitude" value="$params{latitude}"> -<input type="hidden" name="longitude" id="fixmystreet.longitude" value="$params{longitude}"> -<script type="text/javascript"> -var fixmystreet = { - 'latitude': $params{latitude}, - 'longitude': $params{longitude}, - 'pins': [ $pins_js ] -} -</script> -<div id="map_box"> - $params{pre} - <div id="map"></div> - <p id="copyright">$copyright</p> - $params{post} -</div> -<div id="side"> -EOF - return $out; + my ($self, $c, %params) = @_; + $c->stash->{map} = { + %params, + type => 'google', + }; } 1; diff --git a/perllib/FixMyStreet/Map/OSM.pm b/perllib/FixMyStreet/Map/OSM.pm index b930a4e4d..05dc6ad39 100644 --- a/perllib/FixMyStreet/Map/OSM.pm +++ b/perllib/FixMyStreet/Map/OSM.pm @@ -10,116 +10,126 @@ package FixMyStreet::Map::OSM; use strict; use Math::Trig; -use mySociety::Web qw(ent NewURL); +use mySociety::Gaze; use Utils; -sub header_js { - return ' -<script type="text/javascript" src="/jslib/OpenLayers-2.10/OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-OpenStreetMap.js"></script> -'; -} +use constant ZOOM_LEVELS => 5; +use constant MIN_ZOOM_LEVEL => 13; sub map_type { return 'OpenLayers.Layer.OSM.Mapnik'; } -# display_map Q PARAMS +sub map_template { + return 'osm'; +} + +sub map_tiles { + my ($self, $x, $y, $z) = @_; + my $tile_url = $self->base_tile_url(); + return [ + "http://a.$tile_url/$z/" . ($x - 1) . "/" . ($y - 1) . ".png", + "http://b.$tile_url/$z/$x/" . ($y - 1) . ".png", + "http://c.$tile_url/$z/" . ($x - 1) . "/$y.png", + "http://$tile_url/$z/$x/$y.png", + ]; +} + +sub base_tile_url { + return 'tile.openstreetmap.org'; +} + +sub copyright { + return _('Map © <a id="osm_link" href="http://www.openstreetmap.org/">OpenStreetMap</a> and contributors, <a href="http://creativecommons.org/licenses/by-sa/2.0/">CC-BY-SA</a>'); +} + +# display_map C PARAMS # PARAMS include: # latitude, longitude for the centre point of the map -# TYPE is 1 if the map is clickable, 2 if clickable and has a form upload, -# 0 if not clickable +# CLICKABLE is set if the map is clickable # PINS is array of pins to show, location and colour -# PRE/POST are HTML to show above/below map sub display_map { - my ($self, $q, %params) = @_; - $params{pre} ||= ''; - $params{post} ||= ''; + my ($self, $c, %params) = @_; - # Map centre may be overridden in the query string - $params{latitude} = Utils::truncate_coordinate($q->param('lat')+0) - if defined $q->param('lat'); - $params{longitude} = Utils::truncate_coordinate($q->param('lon')+0) - if defined $q->param('lon'); + my $numZoomLevels = ZOOM_LEVELS; + my $zoomOffset = MIN_ZOOM_LEVEL; + if ($params{any_zoom}) { + $numZoomLevels = 18; + $zoomOffset = 0; + } - my $zoom = defined $q->param('zoom') ? $q->param('zoom') : 2; - my $zoom_act = 14 + $zoom; + # Adjust zoom level dependent upon population density + my $dist = mySociety::Gaze::get_radius_containing_population( $params{latitude}, $params{longitude}, 200_000 ); + my $default_zoom = $numZoomLevels - 3; + $default_zoom = $numZoomLevels - 2 if $dist < 10; + + # Map centre may be overridden in the query string + $params{latitude} = Utils::truncate_coordinate($c->req->params->{lat} + 0) + if defined $c->req->params->{lat}; + $params{longitude} = Utils::truncate_coordinate($c->req->params->{lon} + 0) + if defined $c->req->params->{lon}; + + my $zoom = defined $c->req->params->{zoom} ? $c->req->params->{zoom} + 0 : $default_zoom; + $zoom = $numZoomLevels - 1 if $zoom >= $numZoomLevels; + $zoom = 0 if $zoom < 0; + my $zoom_act = $zoomOffset + $zoom; my ($x_tile, $y_tile) = latlon_to_tile_with_adjust($params{latitude}, $params{longitude}, $zoom_act); - my $tl = ($x_tile-1) . "/" . ($y_tile-1); - my $tr = "$x_tile/" . ($y_tile-1); - my $bl = ($x_tile-1) . "/$y_tile"; - my $br = "$x_tile/$y_tile"; - my $tl_src = "http://a.tile.openstreetmap.org/$zoom_act/$tl.png"; - my $tr_src = "http://b.tile.openstreetmap.org/$zoom_act/$tr.png"; - my $bl_src = "http://c.tile.openstreetmap.org/$zoom_act/$bl.png"; - my $br_src = "http://tile.openstreetmap.org/$zoom_act/$br.png"; - map { s{/}{.} } ($tl, $tr, $bl, $br); - - my @pins; - my $pins = ''; foreach my $pin (@{$params{pins}}) { - $pin->[3] ||= ''; - push @pins, "[ $pin->[0], $pin->[1], '$pin->[2]', '$pin->[3]' ]"; - $pins .= display_pin($q, $pin, $x_tile, $y_tile, $zoom_act); + ($pin->{px}, $pin->{py}) = latlon_to_px($pin->{latitude}, $pin->{longitude}, $x_tile, $y_tile, $zoom_act); } - my $pins_js = join(",\n", @pins); - my $img_type; - if ($params{type}) { - $img_type = '<input type="image"'; - } else { - $img_type = '<img'; - } - my $out = FixMyStreet::Map::header($q, $params{type}); - my $copyright = _('Map © <a id="osm_link" href="http://www.openstreetmap.org/">OpenStreetMap</a> and contributors, <a href="http://creativecommons.org/licenses/by-sa/2.0/">CC-BY-SA</a>'); - my $compass = compass($q, $x_tile, $y_tile, $zoom); - my $map_type = $self->map_type(); - $out .= <<EOF; -<input type="hidden" name="latitude" id="fixmystreet.latitude" value="$params{latitude}"> -<input type="hidden" name="longitude" id="fixmystreet.longitude" value="$params{longitude}"> -<input type="hidden" name="zoom" value="$zoom"> -<script type="text/javascript"> -var fixmystreet = { - 'latitude': $params{latitude}, - 'longitude': $params{longitude}, - 'pins': [ $pins_js ], - 'map_type': $map_type + $c->stash->{map} = { + %params, + type => $self->map_template(), + map_type => $self->map_type(), + tiles => $self->map_tiles( $x_tile, $y_tile, $zoom_act ), + copyright => $self->copyright(), + x_tile => $x_tile, + y_tile => $y_tile, + zoom => $zoom, + zoom_act => $zoom_act, + zoomOffset => $zoomOffset, + numZoomLevels => $numZoomLevels, + compass => compass( $x_tile, $y_tile, $zoom_act ), + }; } -</script> -<div id="map_box"> - $params{pre} - <div id="map"><noscript> - <div id="drag">$img_type alt="NW map tile" id="t2.2" name="tile_$tl" src="$tl_src" style="top:0; left:0;">$img_type alt="NE map tile" id="t2.3" name="tile_$tr" src="$tr_src" style="top:0px; left:256px;"><br>$img_type alt="SW map tile" id="t3.2" name="tile_$bl" src="$bl_src" style="top:256px; left:0;">$img_type alt="SE map tile" id="t3.3" name="tile_$br" src="$br_src" style="top:256px; left:256px;"></div> - <div id="pins">$pins</div> - $compass - </noscript></div> - <p id="copyright">$copyright</p> - $params{post} -</div> -<div id="side"> -EOF - return $out; + +sub map_pins { + my ($self, $c, $interval) = @_; + + my $bbox = $c->req->param('bbox'); + my ( $min_lon, $min_lat, $max_lon, $max_lat ) = split /,/, $bbox; + + my ( $around_map, $around_map_list, $nearby, $dist ) = + FixMyStreet::Map::map_features_bounds( $c, $min_lon, $min_lat, $max_lon, $max_lat, $interval ); + + # create a list of all the pins + my @pins = map { + # Here we might have a DB::Problem or a DB::Nearby, we always want the problem. + my $p = (ref $_ eq 'FixMyStreet::App::Model::DB::Nearby') ? $_->problem : $_; + #{ + # latitude => $p->latitude, + # longitude => $p->longitude, + # colour => $p->state eq 'fixed' ? 'green' : 'red', + # id => $p->id, + # title => $p->title, + #} + [ $p->latitude, $p->longitude, $p->state eq 'fixed' ? 'green' : 'red', $p->id, $p->title ] + } @$around_map, @$nearby; + + return (\@pins, $around_map_list, $nearby, $dist); } -sub display_pin { - my ($q, $pin, $x_tile, $y_tile, $zoom) = @_; - - my ($px, $py) = latlon_to_px($pin->[0], $pin->[1], $x_tile, $y_tile, $zoom); - - my $num = ''; - my $host = Page::base_url_with_lang($q, undef); - my %cols = (red=>'R', green=>'G', blue=>'B', purple=>'P'); - my $out = '<img border="0" class="pin" src="' . $host . '/i/pin' . $cols{$pin->[2]} - . $num . '.gif" alt="' . _('Problem') . '" style="top:' . ($py-59) - . 'px; left:' . ($px) . 'px; position: absolute;">'; - return $out unless $pin->[3]; - my $cobrand = Page::get_cobrand($q); - my $url = Cobrand::url($cobrand, NewURL($q, -url => '/report/' . $pin->[3]), $q); - # XXX Would like to include title here in title="" - $out = '<a href="' . $url . '">' . $out . '</a>'; - return $out; +sub compass { + my ( $x, $y, $z ) = @_; + return { + north => [ map { Utils::truncate_coordinate($_) } tile_to_latlon( $x, $y-1, $z ) ], + south => [ map { Utils::truncate_coordinate($_) } tile_to_latlon( $x, $y+1, $z ) ], + west => [ map { Utils::truncate_coordinate($_) } tile_to_latlon( $x-1, $y, $z ) ], + east => [ map { Utils::truncate_coordinate($_) } tile_to_latlon( $x+1, $y, $z ) ], + here => [ map { Utils::truncate_coordinate($_) } tile_to_latlon( $x, $y, $z ) ], + }; } # Given a lat/lon, convert it to OSM tile co-ordinates (precise). @@ -182,44 +192,14 @@ sub click_to_tile { # Given some click co-ords (the tile they were on, and where in the # tile they were), convert to WGS84 and return. +# XXX Note use of MIN_ZOOM_LEVEL here. sub click_to_wgs84 { - my ($self, $q, $pin_tile_x, $pin_x, $pin_tile_y, $pin_y) = @_; + my ($self, $c, $pin_tile_x, $pin_x, $pin_tile_y, $pin_y) = @_; my $tile_x = click_to_tile($pin_tile_x, $pin_x); my $tile_y = click_to_tile($pin_tile_y, $pin_y); - my $zoom = 14 + (defined $q->param('zoom') ? $q->param('zoom') : 2); + my $zoom = MIN_ZOOM_LEVEL + (defined $c->req->params->{zoom} ? $c->req->params->{zoom} : 3); my ($lat, $lon) = tile_to_latlon($tile_x, $tile_y, $zoom); return ( $lat, $lon ); } -sub compass ($$$$) { - my ( $q, $x, $y, $zoom ) = @_; - - my ($lat, $lon) = map { Utils::truncate_coordinate($_) } tile_to_latlon($x, $y-1, $zoom+14); - my $north = NewURL( $q, lat => $lat, lon => $lon, zoom => $zoom ); - ($lat, $lon) = map { Utils::truncate_coordinate($_) } tile_to_latlon($x, $y+1, $zoom+14); - my $south = NewURL( $q, lat => $lat, lon => $lon, zoom => $zoom ); - ($lat, $lon) = map { Utils::truncate_coordinate($_) } tile_to_latlon($x-1, $y, $zoom+14); - my $west = NewURL( $q, lat => $lat, lon => $lon, zoom => $zoom ); - ($lat, $lon) = map { Utils::truncate_coordinate($_) } tile_to_latlon($x+1, $y, $zoom+14); - my $east = NewURL( $q, lat => $lat, lon => $lon, zoom => $zoom ); - ($lat, $lon) = map { Utils::truncate_coordinate($_) } tile_to_latlon($x, $y, $zoom+14); - my $zoom_in = $zoom < 3 ? NewURL( $q, lat => $lat, lon => $lon, zoom => $zoom+1 ) : '#'; - my $zoom_out = $zoom > 0 ? NewURL( $q, lat => $lat, lon => $lon, zoom => $zoom-1 ) : '#'; - my $world = NewURL( $q, lat => $lat, lon => $lon, zoom => 0 ); - - #my $host = Page::base_url_with_lang( $q, undef ); - my $dir = "/jslib/OpenLayers-2.10/img"; - return <<EOF; -<div style="position: absolute; left: 4px; top: 4px; z-index: 1007;" class="olControlPanZoom olControlNoSelect" unselectable="on"> - <div style="position: absolute; left: 13px; top: 4px; width: 18px; height: 18px;"><a href="$north"><img style="position: relative; width: 18px; height: 18px;" src="$dir/north-mini.png" border="0"></a></div> - <div style="position: absolute; left: 4px; top: 22px; width: 18px; height: 18px;"><a href="$west"><img style="position: relative; width: 18px; height: 18px;" src="$dir/west-mini.png" border="0"></a></div> - <div style="position: absolute; left: 22px; top: 22px; width: 18px; height: 18px;"><a href="$east"><img style="position: relative; width: 18px; height: 18px;" src="$dir/east-mini.png" border="0"></a></div> - <div style="position: absolute; left: 13px; top: 40px; width: 18px; height: 18px;"><a href="$south"><img style="position: relative; width: 18px; height: 18px;" src="$dir/south-mini.png" border="0"></a></div> - <div style="position: absolute; left: 13px; top: 63px; width: 18px; height: 18px;"><a href="$zoom_in"><img style="position: relative; width: 18px; height: 18px;" src="$dir/zoom-plus-mini.png" border="0"></a></div> - <div style="position: absolute; left: 13px; top: 81px; width: 18px; height: 18px;"><a href="$world"><img style="position: relative; width: 18px; height: 18px;" src="$dir/zoom-world-mini.png" border="0"></a></div> - <div style="position: absolute; left: 13px; top: 99px; width: 18px; height: 18px;"><a href="$zoom_out"><img style="position: relative; width: 18px; height: 18px;" src="$dir/zoom-minus-mini.png" border="0"></a></div> -</div> -EOF -} - 1; diff --git a/perllib/FixMyStreet/Map/OSM/CycleMap.pm b/perllib/FixMyStreet/Map/OSM/CycleMap.pm index 06b07ae20..71b86de8f 100644 --- a/perllib/FixMyStreet/Map/OSM/CycleMap.pm +++ b/perllib/FixMyStreet/Map/OSM/CycleMap.pm @@ -15,4 +15,8 @@ sub map_type { return 'OpenLayers.Layer.OSM.CycleMap'; } +sub base_tile_url { + return 'tile.opencyclemap.org/cycle'; +} + 1; diff --git a/perllib/FixMyStreet/Map/OSM/StreetView.pm b/perllib/FixMyStreet/Map/OSM/StreetView.pm index 9c9a1ac8e..141c2e328 100644 --- a/perllib/FixMyStreet/Map/OSM/StreetView.pm +++ b/perllib/FixMyStreet/Map/OSM/StreetView.pm @@ -7,58 +7,24 @@ # Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ package FixMyStreet::Map::OSM::StreetView; +use base 'FixMyStreet::Map::OSM'; use strict; -use mySociety::Web qw(ent); -sub header_js { - return ' -<script type="text/javascript" src="/jslib/OpenLayers-2.10/OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-streetview.js"></script> -'; +sub map_type { + return '""'; } -# display_map Q PARAMS -# PARAMS include: -# EASTING, NORTHING for the centre point of the map -# TYPE is 1 if the map is clickable, 2 if clickable and has a form upload, -# 0 if not clickable -# PINS is array of pins to show, location and colour -# PRE/POST are HTML to show above/below map -sub display_map { - my ($self, $q, %params) = @_; - $params{pre} ||= ''; - $params{post} ||= ''; - - my @pins; - foreach my $pin (@{$params{pins}}) { - $pin->[3] ||= ''; - push @pins, "[ $pin->[0], $pin->[1], '$pin->[2]', '$pin->[3]' ]"; - } - my $pins_js = join(",\n", @pins); +sub map_template { + return 'osm-streetview'; +} - my $out = FixMyStreet::Map::header($q, $params{type}); - my $copyright = _('Map contains Ordnance Survey data © Crown copyright and database right 2010.'); - $out .= <<EOF; -<input type="hidden" name="latitude" id="fixmystreet.latitude" value="$params{latitude}"> -<input type="hidden" name="longitude" id="fixmystreet.longitude" value="$params{longitude}"> -<script type="text/javascript"> -var fixmystreet = { - 'latitude': $params{latitude}, - 'longitude': $params{longitude}, - 'pins': [ $pins_js ] +sub base_tile_url { + return 'os.openstreetmap.org/sv'; } -</script> -<div id="map_box"> - $params{pre} - <div id="map"></div> - <p id="copyright">$copyright</p> - $params{post} -</div> -<div id="side"> -EOF - return $out; + +sub copyright { + return _('Map contains Ordnance Survey data © Crown copyright and database right 2010.'); } 1; diff --git a/perllib/FixMyStreet/Map/Tilma/OL/1_10k.pm b/perllib/FixMyStreet/Map/Tilma/OL/1_10k.pm deleted file mode 100644 index 9ae5829c4..000000000 --- a/perllib/FixMyStreet/Map/Tilma/OL/1_10k.pm +++ /dev/null @@ -1,79 +0,0 @@ -#!/usr/bin/perl -# -# FixMyStreet:Map::Tilma::1_10k_OL -# Using tilma.mysociety.org with OpenLayers -# -# Copyright (c) 2010 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ - -package FixMyStreet::Map::Tilma::OL::1_10k; - -use strict; - -use constant TILE_WIDTH => 254; -use constant TIF_SIZE_M => 5000; -use constant TIF_SIZE_PX => 7874; -use constant SCALE_FACTOR => TIF_SIZE_M / (TIF_SIZE_PX / TILE_WIDTH); -use constant TILE_TYPE => '10k-full'; - -sub header_js { - return ' -<script type="text/javascript" src="/jslib/OpenLayers-2.10/OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-tilma-ol.js"></script> -<script type="text/javascript" src="/js/OpenLayers.Projection.OrdnanceSurvey.js"></script> -'; -} - -# display_map Q PARAMS -# PARAMS include: -# EASTING, NORTHING for the centre point of the map -# TYPE is 1 if the map is clickable, 2 if clickable and has a form upload, -# 0 if not clickable -# PINS is array of pins to show, location and colour -# PRE/POST are HTML to show above/below map -sub display_map { - my ($self, $q, %params) = @_; - $params{pre} ||= ''; - $params{post} ||= ''; - - my @pins; - foreach my $pin (@{$params{pins}}) { - $pin->[3] ||= ''; - push @pins, "[ $pin->[0], $pin->[1], '$pin->[2]', '$pin->[3]' ]"; - } - my $pins_js = join(",\n", @pins); - - my $out = FixMyStreet::Map::header($q, $params{type}); - my $tile_width = TILE_WIDTH; - my $tile_type = TILE_TYPE; - my $sf = SCALE_FACTOR / TILE_WIDTH; - my $copyright = _('© Crown copyright. All rights reserved. Ministry of Justice 100037819 2008.'); - $out .= <<EOF; -<input type="hidden" name="latitude" id="fixmystreet.latitude" value="$params{latitude}"> -<input type="hidden" name="longitude" id="fixmystreet.longitude" value="$params{longitude}"> -<script type="text/javascript"> -var fixmystreet = { - 'tilewidth': $tile_width, - 'tileheight': $tile_width, - 'latitude': $params{latitude}, - 'longitude': $params{longitude}, - 'pins': [ $pins_js ], - 'tile_type': '$tile_type', - 'maxResolution': $sf -}; -</script> -<div id="map_box"> - $params{pre} - <div id="map"> - <div id="watermark"></div> - </div> - <p id="copyright">$copyright</p> -$params{post} -</div> -<div id="side"> -EOF - return $out; -} - -1; diff --git a/perllib/FixMyStreet/Map/Tilma/OL/StreetView.pm b/perllib/FixMyStreet/Map/Tilma/OL/StreetView.pm deleted file mode 100644 index 7a898b55b..000000000 --- a/perllib/FixMyStreet/Map/Tilma/OL/StreetView.pm +++ /dev/null @@ -1,77 +0,0 @@ -#!/usr/bin/perl -# -# FixMyStreet:Map::TilmaXY -# Using tilma.mysociety.org but accessing images directly. -# -# Copyright (c) 2010 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ - -package FixMyStreet::Map::Tilma::OL::StreetView; - -use strict; - -use constant TILE_WIDTH => 250; -use constant TIF_SIZE_M => 5000; -use constant TIF_SIZE_PX => 5000; -use constant SCALE_FACTOR => TIF_SIZE_M / (TIF_SIZE_PX / TILE_WIDTH); -use constant TILE_TYPE => 'streetview'; - -sub header_js { - return ' -<script type="text/javascript" src="/jslib/OpenLayers-2.10/OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-OpenLayers.js"></script> -<script type="text/javascript" src="/js/map-tilma-ol.js"></script> -<script type="text/javascript" src="/js/OpenLayers.Projection.OrdnanceSurvey.js"></script> -'; -} - -# display_map Q PARAMS -# PARAMS include: -# EASTING, NORTHING for the centre point of the map -# TYPE is 1 if the map is clickable, 2 if clickable and has a form upload, -# 0 if not clickable -# PINS is array of pins to show, location and colour -# PRE/POST are HTML to show above/below map -sub display_map { - my ($self, $q, %params) = @_; - $params{pre} ||= ''; - $params{post} ||= ''; - - my @pins; - foreach my $pin (@{$params{pins}}) { - $pin->[3] ||= ''; - push @pins, "[ $pin->[0], $pin->[1], '$pin->[2]', '$pin->[3]' ]"; - } - my $pins_js = join(",\n", @pins); - - my $out = FixMyStreet::Map::header($q, $params{type}); - my $tile_width = TILE_WIDTH; - my $tile_type = TILE_TYPE; - my $sf = SCALE_FACTOR / TILE_WIDTH; - my $copyright = _('Map contains Ordnance Survey data © Crown copyright and database right 2010.'); - $out .= <<EOF; -<input type="hidden" name="latitude" id="fixmystreet.latitude" value="$params{latitude}"> -<input type="hidden" name="longitude" id="fixmystreet.longitude" value="$params{longitude}"> -<script type="text/javascript"> -var fixmystreet = { - 'tilewidth': $tile_width, - 'tileheight': $tile_width, - 'latitude': $params{latitude}, - 'longitude': $params{longitude}, - 'pins': [ $pins_js ], - 'tile_type': '$tile_type', - 'maxResolution': $sf -}; -</script> -<div id="map_box"> - $params{pre} - <div id="map"></div> - <p id="copyright">$copyright</p> - $params{post} -</div> -<div id="side"> -EOF - return $out; -} - -1; diff --git a/perllib/FixMyStreet/Map/Tilma/Original.pm b/perllib/FixMyStreet/Map/Tilma/Original.pm deleted file mode 100644 index 0af6ed277..000000000 --- a/perllib/FixMyStreet/Map/Tilma/Original.pm +++ /dev/null @@ -1,337 +0,0 @@ -#!/usr/bin/perl -# -# FixMyStreet:Map -# Adding the ability to have different maps on FixMyStreet. -# -# Copyright (c) 2010 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ - -package FixMyStreet::Map::Tilma::Original; - -use strict; -use LWP::Simple; - -use Cobrand; -use mySociety::GeoUtil; -use mySociety::Locale; -use mySociety::Web qw(ent NewURL); -use Utils; -use RABX; - -sub TILE_WIDTH() { return $FixMyStreet::Map::map_class->tile_width; } -sub SCALE_FACTOR() { return $FixMyStreet::Map::map_class->scale_factor; } -sub TILE_TYPE() { return $FixMyStreet::Map::map_class->tile_type; } - -sub _ll_to_en { - my ($lat, $lon) = @_; - return Utils::convert_latlon_to_en( $lat, $lon ); -} - -sub header_js { - return ' -<script type="text/javascript" src="/js/map-tilma.js"></script> -'; -} - -# display_map Q PARAMS -# PARAMS include: -# latitude, longitude for the centre point of the map -# TYPE is 1 if the map is clickable, 2 if clickable and has a form upload, -# 0 if not clickable -# PINS is array of pins to show, location and colour -# PRE/POST are HTML to show above/below map -sub display_map { - my ($self, $q, %params) = @_; - $params{pre} ||= ''; - $params{post} ||= ''; - my $mid_point = TILE_WIDTH; # Map is 2 TILE_WIDTHs in size, square. - if (my $mp = Cobrand::tilma_mid_point(Page::get_cobrand($q))) { - $mid_point = $mp; - } - - # convert map center point to easting, northing - ( $params{easting}, $params{northing} ) = - _ll_to_en( $params{latitude}, $params{longitude} ); - - # FIXME - convert all pins to lat, lng - # all the pins are currently [lat, lng, colour] - convert them - foreach my $pin ( @{ $params{pins} ||= [] } ) { - my ( $lat, $lon ) = ( $pin->[0], $pin->[1] ); - my ( $e, $n ) = _ll_to_en( $lat, $lon ); - ( $pin->[0], $pin->[1] ) = ( $e, $n ); - } - - # X/Y tile co-ords may be overridden in the query string - my @vars = qw(x y); - my %input = map { $_ => $q->param($_) || '' } @vars; - ($input{x}) = $input{x} =~ /^(\d+)/; $input{x} ||= 0; - ($input{y}) = $input{y} =~ /^(\d+)/; $input{y} ||= 0; - - my ($x, $y, $px, $py) = os_to_px_with_adjust($q, $params{easting}, $params{northing}, $input{x}, $input{y}); - - my $pins = ''; - foreach my $pin (@{$params{pins}}) { - my $pin_x = os_to_px($pin->[0], $x); - my $pin_y = os_to_px($pin->[1], $y, 1); - $pins .= display_pin($q, $pin_x, $pin_y, $pin->[2]); - } - - $px = defined($px) ? $mid_point - $px : 0; - $py = defined($py) ? $mid_point - $py : 0; - $x = int($x)<=0 ? 0 : $x; - $y = int($y)<=0 ? 0 : $y; - my $url = 'http://tilma.mysociety.org/tileserver/' . TILE_TYPE . '/'; - my $tiles_url = $url . ($x-1) . '-' . $x . ',' . ($y-1) . '-' . $y . '/RABX'; - my $tiles = LWP::Simple::get($tiles_url); - return '<div id="map_box"> <div id="map"><div id="drag">' . _("Unable to fetch the map tiles from the tile server.") . '</div></div></div><div id="side">' if !$tiles; - my $tileids = RABX::unserialise($tiles); - my $tl = ($x-1) . '.' . $y; - my $tr = $x . '.' . $y; - my $bl = ($x-1) . '.' . ($y-1); - my $br = $x . '.' . ($y-1); - return '<div id="side">' if (!$tileids->[0][0] || !$tileids->[0][1] || !$tileids->[1][0] || !$tileids->[1][1]); - my $tl_src = $url . $tileids->[0][0]; - my $tr_src = $url . $tileids->[0][1]; - my $bl_src = $url . $tileids->[1][0]; - my $br_src = $url . $tileids->[1][1]; - - my $cobrand = Page::get_cobrand($q); - my $root_path_js = Cobrand::root_path_js($cobrand, $q); - my $out = FixMyStreet::Map::header($q, $params{type}); - my $img_type; - if ($params{type}) { - $out .= <<EOF; -<input type="hidden" name="x" id="formX" value="$x"> -<input type="hidden" name="y" id="formY" value="$y"> -<input type="hidden" name="latitude" value="$params{latitude}"> -<input type="hidden" name="longitude" value="$params{longitude}"> -EOF - $img_type = '<input type="image"'; - } else { - $img_type = '<img'; - } - my $imgw = TILE_WIDTH . 'px'; - my $tile_width = TILE_WIDTH; - my $tile_type = TILE_TYPE; - $out .= <<EOF; -<script type="text/javascript"> -$root_path_js -var fixmystreet = { - 'x': $x - 3, - 'y': $y - 3, - 'start_x': $px, - 'start_y': $py, - 'tile_type': '$tile_type', - 'tilewidth': $tile_width, - 'tileheight': $tile_width -}; -</script> -<div id="map_box"> -$params{pre} - <div id="map"><div id="drag"> - $img_type alt="NW map tile" id="t2.2" name="tile_$tl" src="$tl_src" style="top:0px; left:0;">$img_type alt="NE map tile" id="t2.3" name="tile_$tr" src="$tr_src" style="top:0px; left:$imgw;"><br>$img_type alt="SW map tile" id="t3.2" name="tile_$bl" src="$bl_src" style="top:$imgw; left:0;">$img_type alt="SE map tile" id="t3.3" name="tile_$br" src="$br_src" style="top:$imgw; left:$imgw;"> - <div id="pins">$pins</div> - </div> -EOF - $out .= '<div id="watermark"></div>' if $self->watermark(); - $out .= compass($q, $x, $y); - my $copyright = $self->copyright(); - $out .= <<EOF; - </div> - <p id="copyright">$copyright</p> -$params{post} -</div> -<div id="side"> -EOF - return $out; -} - -sub display_pin { - my ($q, $px, $py, $col, $num) = @_; - $num = '' if !$num || $num > 9; - my $host = Page::base_url_with_lang($q, undef); - my %cols = (red=>'R', green=>'G', blue=>'B', purple=>'P'); - my $out = '<img class="pin" src="' . $host . '/i/pin' . $cols{$col} - . $num . '.gif" alt="' . _('Problem') . '" style="top:' . ($py-59) - . 'px; left:' . ($px) . 'px; position: absolute;">'; - return $out unless $_ && $_->{id} && $col ne 'blue'; - my $cobrand = Page::get_cobrand($q); - my $url = Cobrand::url($cobrand, NewURL($q, -url => '/report/' . $_->{id}), $q); - $out = '<a title="' . ent($_->{title}) . '" href="' . $url . '">' . $out . '</a>'; - return $out; -} - -sub map_pins { - my ($self, $q, $x, $y, $sx, $sy, $interval) = @_; - - my $e = tile_to_os($x); - my $n = tile_to_os($y); - - my ( $lat, $lon ) = Utils::convert_en_to_latlon( $e, $n ); - my ( $around_map, $around_map_list, $nearby, $dist ) = - FixMyStreet::Map::map_features( $q, $lat, $lon, $interval ); - - my $pins = ''; - foreach (@$around_map) { - ( $_->{easting}, $_->{northing} ) = - _ll_to_en( $_->{latitude}, $_->{longitude} ); - my $px = os_to_px($_->{easting}, $sx); - my $py = os_to_px($_->{northing}, $sy, 1); - my $col = $_->{state} eq 'fixed' ? 'green' : 'red'; - $pins .= display_pin($q, $px, $py, $col); - } - - foreach (@$nearby) { - ( $_->{easting}, $_->{northing} ) = - _ll_to_en( $_->{latitude}, $_->{longitude} ); - my $px = os_to_px($_->{easting}, $sx); - my $py = os_to_px($_->{northing}, $sy, 1); - my $col = $_->{state} eq 'fixed' ? 'green' : 'red'; - $pins .= display_pin($q, $px, $py, $col); - } - - return ($pins, $around_map_list, $nearby, $dist); -} - -# P is easting or northing -# C is centre tile reference of displayed map -sub os_to_px { - my ($p, $c, $invert) = @_; - return tile_to_px(os_to_tile($p), $c, $invert); -} - -# Convert tile co-ordinates to pixel co-ordinates from top left of map -# C is centre tile reference of displayed map -sub tile_to_px { - my ($p, $c, $invert) = @_; - $p = TILE_WIDTH * ($p - $c + 1); - $p = 2 * TILE_WIDTH - $p if $invert; - $p = int($p + .5 * ($p <=> 0)); - return $p; -} - -# Tile co-ordinates are linear scale of OS E/N -# Will need more generalising when more zooms appear -sub os_to_tile { - return $_[0] / SCALE_FACTOR; -} - -sub tile_to_os { - return int($_[0] * SCALE_FACTOR + 0.5); -} - -=head2 tile_xy_to_wgs84 - - ($lat, $lon) = tile_xy_to_wgs84( $x, $y ); - -Takes the tile x,y and converts to lat, lon. - -=cut - -sub tile_xy_to_wgs84 { - my ( $self, $x, $y ) = @_; - - my $easting = tile_to_os($x); - my $northing = tile_to_os($y); - - my ( $lat, $lon ) = Utils::convert_en_to_latlon( $easting, $northing ); - return ( $lat, $lon ); -} - - -sub click_to_tile { - my ($pin_tile, $pin, $invert) = @_; - $pin -= TILE_WIDTH while $pin > TILE_WIDTH; - $pin += TILE_WIDTH while $pin < 0; - $pin = TILE_WIDTH - $pin if $invert; # image submits measured from top down - return $pin_tile + $pin / TILE_WIDTH; -} - -# Given some click co-ords (the tile they were on, and where in the -# tile they were), convert to OSGB36 and return. -sub click_to_os { - my ($pin_tile_x, $pin_x, $pin_tile_y, $pin_y) = @_; - my $tile_x = click_to_tile($pin_tile_x, $pin_x); - my $tile_y = click_to_tile($pin_tile_y, $pin_y, 1); - my $easting = tile_to_os($tile_x); - my $northing = tile_to_os($tile_y); - return ($easting, $northing); -} - -# Given some click co-ords (the tile they were on, and where in the -# tile they were), convert to WGS84 and return. -sub click_to_wgs84 { - my $self = shift; - my $q = shift; - my ( $easting, $northing ) = click_to_os(@_); - my ( $lat, $lon ) = mySociety::GeoUtil::national_grid_to_wgs84( $easting, $northing, 'G' ); - return ( $lat, $lon ); -} - -# Given (E,N) and potential override (X,Y), return the X/Y tile for the centre -# of the map (either to get the point near the middle, or the override X,Y), -# and the pixel co-ords of the point, relative to that map. -sub os_to_px_with_adjust { - my ($q, $easting, $northing, $in_x, $in_y) = @_; - - my $x = os_to_tile($easting); - my $y = os_to_tile($northing); - my $x_tile = $in_x || int($x); - my $y_tile = $in_y || int($y); - - # Try and have point near centre of map - if (!$in_x && $x - $x_tile > 0.5) { - $x_tile += 1; - } - if (!$in_y && $y - $y_tile > 0.5) { - $y_tile += 1; - } - - my $px = os_to_px($easting, $x_tile); - my $py = os_to_px($northing, $y_tile, 1); - if ($q->{site} eq 'barnet') { # Map is 380px, so might need to adjust - if (!$in_x && $px > 380) { - $x_tile++; - $px = os_to_px($easting, $x_tile); - } - if (!$in_y && $py > 380) { - $y_tile--; - $py = os_to_px($northing, $y_tile, 1); - } - } - - return ($x_tile, $y_tile, $px, $py); -} - -sub compass ($$$) { - my ( $q, $x, $y ) = @_; - my @compass; - for ( my $i = $x - 1 ; $i <= $x + 1 ; $i++ ) { - for ( my $j = $y - 1 ; $j <= $y + 1 ; $j++ ) { - $compass[$i][$j] = NewURL( $q, x => $i, y => $j ); - } - } - my $recentre = NewURL($q); - my $host = Page::base_url_with_lang( $q, undef ); - return <<EOF; -<table cellpadding="0" cellspacing="0" border="0" id="compass"> -<tr valign="bottom"> -<td align="right"><a rel="nofollow" href="${compass[$x-1][$y+1]}"><img src="$host/i/arrow-northwest.gif" alt="NW" width=11 height=11></a></td> -<td align="center"><a rel="nofollow" href="${compass[$x][$y+1]}"><img src="$host/i/arrow-north.gif" vspace="3" alt="N" width=13 height=11></a></td> -<td><a rel="nofollow" href="${compass[$x+1][$y+1]}"><img src="$host/i/arrow-northeast.gif" alt="NE" width=11 height=11></a></td> -</tr> -<tr> -<td><a rel="nofollow" href="${compass[$x-1][$y]}"><img src="$host/i/arrow-west.gif" hspace="3" alt="W" width=11 height=13></a></td> -<td align="center"><a rel="nofollow" href="$recentre"><img src="$host/i/rose.gif" alt="Recentre" width=35 height=34></a></td> -<td><a rel="nofollow" href="${compass[$x+1][$y]}"><img src="$host/i/arrow-east.gif" hspace="3" alt="E" width=11 height=13></a></td> -</tr> -<tr valign="top"> -<td align="right"><a rel="nofollow" href="${compass[$x-1][$y-1]}"><img src="$host/i/arrow-southwest.gif" alt="SW" width=11 height=11></a></td> -<td align="center"><a rel="nofollow" href="${compass[$x][$y-1]}"><img src="$host/i/arrow-south.gif" vspace="3" alt="S" width=13 height=11></a></td> -<td><a rel="nofollow" href="${compass[$x+1][$y-1]}"><img src="$host/i/arrow-southeast.gif" alt="SE" width=11 height=11></a></td> -</tr> -</table> -EOF -} - -1; diff --git a/perllib/FixMyStreet/Map/Tilma/Original/1_10k.pm b/perllib/FixMyStreet/Map/Tilma/Original/1_10k.pm deleted file mode 100644 index 722df2a46..000000000 --- a/perllib/FixMyStreet/Map/Tilma/Original/1_10k.pm +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/perl -# -# FixMyStreet:Map -# Adding the ability to have different maps on FixMyStreet. -# -# Copyright (c) 2010 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ - -package FixMyStreet::Map::Tilma::Original::1_10k; -use base 'FixMyStreet::Map::Tilma::Original'; - -use strict; - -sub tile_width { return 254; } -sub tif_size_m { return 5000; } -sub tif_size_px { return 7874; } -sub scale_factor { return tif_size_m() / (tif_size_px() / tile_width()); } -sub tile_type { return '10k-full'; } - -sub copyright { - return _('© Crown copyright. All rights reserved. Ministry of Justice 100037819 2008.'); -} - -sub watermark { - return 1; -} - -1; diff --git a/perllib/FixMyStreet/Map/Tilma/Original/StreetView.pm b/perllib/FixMyStreet/Map/Tilma/Original/StreetView.pm deleted file mode 100644 index fe03fdb00..000000000 --- a/perllib/FixMyStreet/Map/Tilma/Original/StreetView.pm +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/perl -# -# FixMyStreet:Map -# Adding the ability to have different maps on FixMyStreet. -# -# Copyright (c) 2010 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ - -package FixMyStreet::Map::Tilma::Original::StreetView; -use base 'FixMyStreet::Map::Tilma::Original'; - -use strict; - -sub tile_width { return 250; } -sub tif_size_m { return 5000; } -sub tif_size_px { return 5000; } -sub scale_factor { return tif_size_m() / (tif_size_px() / tile_width()); } -sub tile_type { return 'streetview'; } - -sub copyright { - return _('Map contains Ordnance Survey data © Crown copyright and database right 2010.'); -} - -sub watermark { - return 0; -} - -1; diff --git a/perllib/FixMyStreet/Roles/Abuser.pm b/perllib/FixMyStreet/Roles/Abuser.pm new file mode 100644 index 000000000..b9e951305 --- /dev/null +++ b/perllib/FixMyStreet/Roles/Abuser.pm @@ -0,0 +1,29 @@ +package FixMyStreet::Roles::Abuser; + +use Moose::Role; + +=head2 is_from_abuser + + $bool = $alert->is_from_abuser( ); + +Returns true if the user's email or its domain is listed in the 'abuse' table. + +=cut + +sub is_from_abuser { + my $self = shift; + + # get the domain + my $email = $self->user->email; + my ($domain) = $email =~ m{ @ (.*) \z }x; + + # search for an entry in the abuse table + my $abuse_rs = $self->result_source->schema->resultset('Abuse'); + + return + $abuse_rs->find( { email => $email } ) + || $abuse_rs->find( { email => $domain } ) + || undef; +} + +1; diff --git a/perllib/FixMyStreet/TestMech.pm b/perllib/FixMyStreet/TestMech.pm new file mode 100644 index 000000000..1391254b6 --- /dev/null +++ b/perllib/FixMyStreet/TestMech.pm @@ -0,0 +1,493 @@ +package FixMyStreet::TestMech; +use base qw(Test::WWW::Mechanize::Catalyst Test::Builder::Module); + +use strict; +use warnings; + +BEGIN { + use FixMyStreet; + FixMyStreet->test_mode(1); +} + +use Test::WWW::Mechanize::Catalyst 'FixMyStreet::App'; +use Test::More; +use Web::Scraper; +use Carp; +use Email::Send::Test; +use JSON; + +=head1 NAME + +FixMyStreet::TestMech - T::WWW::M:C but with FMS specific smarts + +=head1 DESCRIPTION + +This module subclasses L<Test::WWW::Mechanize::Catalyst> and adds some +FixMyStreet specific smarts - such as the ability to scrape the resulting page +for form error messages. + +Note - using this module puts L<FixMyStreet::App> into test mode - so for +example emails will not get sent. + +=head1 METHODS + +=head2 check_not_logged_in, check_logged_in + + $bool = $mech->check_not_logged_in(); + $bool = $mech->check_logged_in(); + +Check that the current mech is not logged or logged in as a user. Produces test output. +Returns true test passed, false otherwise. + +=cut + +sub not_logged_in_ok { + my $mech = shift; + $mech->builder->ok( $mech->get('/auth/check_auth')->code == 401, + "not logged in" ); +} + +sub logged_in_ok { + my $mech = shift; + $mech->builder->ok( $mech->get('/auth/check_auth')->code == 200, + "logged in" ); +} + +=head2 create_user_ok + + $user = $mech->create_user_ok( $email ); + +Create a test user (or find it and return if it already exists). + +=cut + +sub create_user_ok { + my $self = shift; + my ($email) = @_; + + my $user = + FixMyStreet::App->model('DB::User') + ->find_or_create( { email => $email } ); + ok $user, "found/created user for $email"; + + return $user; +} + +=head2 log_in_ok + + $user = $mech->log_in_ok( $email_address ); + +Log in with the email given. If email does not match an account then create one. + +=cut + +sub log_in_ok { + my $mech = shift; + my $email = shift; + + my $user = $mech->create_user_ok($email); + + # store the old password and then change it + my $old_password = $user->password; + $user->update( { password => 'secret' } ); + + # log in + $mech->get_ok('/auth'); + $mech->submit_form_ok( + { with_fields => { email => $email, password_sign_in => 'secret' } }, + "sign in using form" ); + $mech->logged_in_ok; + + # restore the password (if there was one) + $user->update( { password => $old_password } ) if $old_password; + + return $user; +} + +=head2 log_out_ok + + $bool = $mech->log_out_ok( ); + +Log out the current user + +=cut + +sub log_out_ok { + my $mech = shift; + $mech->get_ok('/auth/sign_out'); + $mech->not_logged_in_ok; +} + +=head2 delete_user + + $mech->delete_user( $user ); + $mech->delete_user( $email ); + +Delete the current user, including linked objects like problems etc. Can be +either a user object or an email address. + +=cut + +sub delete_user { + my $mech = shift; + my $email_or_user = shift; + + my $user = + ref $email_or_user + ? $email_or_user + : FixMyStreet::App->model('DB::User') + ->find( { email => $email_or_user } ); + + # If no user found we can't delete them + if ( !$user ) { + ok( 1, "No user found to delete" ); + return 1; + } + + $mech->log_out_ok; + for my $p ( $user->problems ) { + ok( $_->delete, "delete comment " . $_->text ) for $p->comments; + ok( $_->delete, "delete questionnaire " . $_->id ) for $p->questionnaires; + ok( $p->delete, "delete problem " . $p->title ); + } + for my $a ( $user->alerts ) { + $a->alert_sents->delete; + ok( $a->delete, "delete alert " . $a->alert_type ); + } + ok( $_->delete, "delete comment " . $_->text ) for $user->comments; + ok $user->delete, "delete test user " . $user->email; + + return 1; +} + +=head2 clear_emails_ok + + $bool = $mech->clear_emails_ok(); + +Clear the email queue. + +=cut + +sub clear_emails_ok { + my $mech = shift; + Email::Send::Test->clear; + $mech->builder->ok( 1, 'cleared email queue' ); + return 1; +} + +=head2 email_count_is + + $bool = $mech->email_count_is( $number ); + +Check that the number of emails in queue is correct. + +=cut + +sub email_count_is { + my $mech = shift; + my $number = shift || 0; + + $mech->builder->is_num( scalar( Email::Send::Test->emails ), + $number, "checking for $number email(s) in the queue" ); +} + +=head2 get_email + + $email = $mech->get_email; + +In scalar context returns first email in queue and fails a test if there are not exactly one emails in the queue. + +In list context returns all the emails (or none). + +=cut + +sub get_email { + my $mech = shift; + my @emails = Email::Send::Test->emails; + + return @emails if wantarray; + + $mech->email_count_is(1) || return undef; + return $emails[0]; +} + +=head2 form_errors + + my $arrayref = $mech->form_errors; + +Find all the form errors on the current page and return them in page order as an +arrayref of TEXTs. If none found return empty arrayref. + +=cut + +sub form_errors { + my $mech = shift; + my $result = scraper { + process 'div.form-error', 'errors[]', 'TEXT'; + } + ->scrape( $mech->response ); + return $result->{errors} || []; +} + +=head2 page_errors + + my $arrayref = $mech->page_errors; + +Find all the form errors on the current page and return them in page order as an +arrayref of TEXTs. If none found return empty arrayref. + +=cut + +sub page_errors { + my $mech = shift; + my $result = scraper { + process 'p.error', 'errors[]', 'TEXT'; + process 'ul.error li', 'errors[]', 'TEXT'; + } + ->scrape( $mech->response ); + return $result->{errors} || []; +} + +=head2 import_errors + + my $arrayref = $mech->import_errors; + +Takes the text output from the import post result and returns all the errors as +an arrayref. + +=cut + +sub import_errors { + my $mech = shift; + my @errors = # + grep { $_ } # + map { s{^ERROR:\s*(.*)$}{$1}g ? $_ : undef; } # + split m/\n+/, $mech->response->content; + return \@errors; +} + +=head2 pc_alternatives + + my $arrayref = $mech->pc_alternatives; + +Find all the suggestions for near matches for a location. Return text presented to user as arrayref, empty arrayref if none found. + +=cut + +sub pc_alternatives { + my $mech = shift; + my $result = scraper { + process 'ul.pc_alternatives li', 'pc_alternatives[]', 'TEXT'; + } + ->scrape( $mech->response ); + return $result->{pc_alternatives} || []; +} + +=head2 extract_location + + $hashref = $mech->extract_location( ); + +Extracts the location from the current page. Looks for inputs with the names +C<pc>, C<latitude> and C<longitude> and returns their values in a hashref with +those keys. If no values found then the values in hashrof are C<undef>. + +=cut + +sub extract_location { + my $mech = shift; + + my $result = scraper { + process 'input[name="pc"]', pc => '@value'; + process 'input[name="latitude"]', latitude => '@value'; + process 'input[name="longitude"]', longitude => '@value'; + } + ->scrape( $mech->response ); + + return { + pc => undef, + latitude => undef, + longitude => undef, + %$result + }; +} + +=head2 extract_problem_meta + + $meta = $mech->extract_problem_meta; + +Returns the problem meta information ( submitted by, at etc ) from a +problem report page + +=cut + +sub extract_problem_meta { + my $mech = shift; + + my $result = scraper { + process 'div#side p em', 'meta', 'TEXT'; + } + ->scrape( $mech->response ); + + my ($meta) = map { s/^\s+//; s/\s+$//; $_; } ($result->{meta}); + + return $meta; +} + +=head2 extract_problem_title + + $title = $mech->extract_problem_title; + +Returns the problem title from a problem report page. + +=cut + +sub extract_problem_title { + my $mech = shift; + + my $result = scraper { + process 'div#side h1', 'title', 'TEXT'; + } + ->scrape( $mech->response ); + + return $result->{title}; +} + +=head2 extract_problem_banner + + $banner = $mech->extract_problem_banner; + +Returns the problem title from a problem report page. Returns a hashref with id and text. + +=cut + +sub extract_problem_banner { + my $mech = shift; + + my $result = scraper { + process 'div#side > p', id => '@id', text => 'TEXT'; + } + ->scrape( $mech->response ); + + return $result; +} + +=head2 extract_update_metas + + $metas = $mech->extract_update_metas; + +Returns an array ref of all the update meta information on the page. Strips whitespace from +the start and end of all of them. + +=cut + +sub extract_update_metas { + my $mech = shift; + + my $result = scraper { + process 'div#updates div.problem-update p em', 'meta[]', 'TEXT'; + } + ->scrape( $mech->response ); + + my @metas = map { s/^\s+//; s/\s+$//; $_; } @{ $result->{meta} }; + + return \@metas; +} + +=head2 visible_form_values + + $hashref = $mech->visible_form_values( ); + +Return all the visible form values on the page - ie not the hidden ones. + +=cut + +sub visible_form_values { + my $mech = shift; + my $name = shift || ''; + + my $form; + + if ($name) { + for ( $mech->forms ) { + $form = $_ if ( $_->attr('name') || '' ) eq $name; + } + croak "Can't find form named $name - can't continue..." + unless $form; + } + else { + my @forms = + grep { ( $_->attr('name') || '' ) ne 'overrides_form' } # ignore overrides + $mech->forms; + + croak "Found no forms - can't continue..." + unless @forms; + + croak "Found several forms - don't know which to use..." + if @forms > 1; + + $form = $forms[0]; + } + + my @visible_fields = + grep { ref($_) ne 'HTML::Form::SubmitInput' } + grep { ref($_) ne 'HTML::Form::ImageInput' } + grep { ref($_) ne 'HTML::Form::TextInput' || $_->type ne 'hidden' } + $form->inputs; + + my @visible_field_names = map { $_->name } @visible_fields; + + my %params = map { $_ => $form->value($_) } @visible_field_names; + + return \%params; +} + +=head2 session_cookie_expiry + + $expiry = $mech->session_cookie_expiry( ); + +Returns the current expiry time for the session cookie. Might be '0' which +indicates it expires at end of browser session. + +=cut + +sub session_cookie_expiry { + my $mech = shift; + + my $cookie_name = 'fixmystreet_app_session'; + my $expires = 'not found'; + + $mech # + ->cookie_jar # + ->scan( sub { $expires = $_[8] if $_[1] eq $cookie_name } ); + + croak "Could not find cookie '$cookie_name'" + if $expires && $expires eq 'not found'; + + return $expires || 0; +} + +=head2 get_ok_json + + $decoded = $mech->get_ok_json( $url ); + +Get the url, check that it was JSON and then decode and return the body. + +=cut + +sub get_ok_json { + my $mech = shift; + my $url = shift; + + # try to get the response + $mech->get_ok($url) + || return undef; + my $res = $mech->response; + + # check that the content-type of response is correct + croak "Response was not JSON" + unless $res->header('Content-Type') =~ m{^application/json\b}; + + return decode_json( $res->content ); +} + +1; diff --git a/perllib/Page.pm b/perllib/Page.pm deleted file mode 100644 index a52f455b4..000000000 --- a/perllib/Page.pm +++ /dev/null @@ -1,781 +0,0 @@ -#!/usr/bin/perl -# -# Page.pm: -# Various HTML stuff for the FixMyStreet site. -# -# Copyright (c) 2006 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ -# -# $Id: Page.pm,v 1.230 2010-01-15 17:08:55 matthew Exp $ -# - -package Page; - -use strict; -use Carp; -use mySociety::CGIFast qw(-no_xhtml); -use Data::Dumper; -use Encode; -use Error qw(:try); -use File::Slurp; -use HTTP::Date; # time2str -use Image::Magick; -use Image::Size; -use IO::String; -use POSIX qw(strftime); -use URI::Escape; -use Text::Template; - -use Memcached; -use Problems; -use Cobrand; - -use mySociety::Config; -use mySociety::DBHandle qw/dbh select_all/; -use mySociety::Email; -use mySociety::EvEl; -use mySociety::Locale; -use mySociety::MaPit; -use mySociety::TempFiles; -use mySociety::WatchUpdate; -use mySociety::Web qw(ent); - -BEGIN { - (my $dir = __FILE__) =~ s{/[^/]*?$}{}; - mySociety::Config::set_file("$dir/../conf/general"); -} - -# Under the BEGIN so that the config has been set. -use FixMyStreet::Map; - -my $lastmodified; - -sub do_fastcgi { - my ($func, $lm, $binary) = @_; - - try { - my $W = new mySociety::WatchUpdate(); - while (my $q = new mySociety::Web(unicode => 1)) { - next if $lm && $q->Maybe304($lm); - $lastmodified = $lm; - microsite($q); - my $str_fh = IO::String->new; - my $old_fh = select($str_fh); - &$func($q); - select($old_fh) if defined $old_fh; - print $binary ? ${$str_fh->string_ref} : encode_utf8(${$str_fh->string_ref}); - dbh()->rollback() if $mySociety::DBHandle::conf_ok; - $W->exit_if_changed(); - } - } catch Error::Simple with { - report_error(@_); - } catch Error with { - report_error(@_); - }; - dbh()->rollback() if $mySociety::DBHandle::conf_ok; - exit(0); -} - -sub report_error { - my $E = shift; - my $msg = sprintf('%s:%d: %s', $E->file(), $E->line(), CGI::escapeHTML($E->text())); - warn "caught fatal exception: $msg"; - warn "aborting"; - ent($msg); - my $contact_email = mySociety::Config::get('CONTACT_EMAIL'); - my $trylater = sprintf(_('Please try again later, or <a href="mailto:%s">email us</a> to let us know.'), $contact_email); - my $somethingwrong = _("Sorry! Something's gone wrong."); - my $errortext = _("The text of the error was:"); - - my $msg_br = join '<br><br>', split m{\n}, $msg; - - print "Status: 500\nContent-Type: text/html; charset=utf-8\n\n", - qq(<html><head><title>$somethingwrong</title></head></html>), - q(<body>), - qq(<h1>$somethingwrong</h1>), - qq(<p>$trylater</p>), - q(<hr>), - qq(<p>$errortext</p>), - qq(<blockquote class="errortext">$msg_br</blockquote>), - q(</body></html>); -} - -=item microsite Q - -Work out what site we're on, template appropriately - -=cut -sub microsite { - my $q = shift; - my $host = $ENV{HTTP_HOST} || ''; - $q->{site} = 'fixmystreet'; - my $allowed_cobrands = Cobrand::get_allowed_cobrands(); - foreach my $cobrand (@{$allowed_cobrands}){ - $q->{site} = $cobrand if $host =~ /$cobrand/; - } - - my $lang; - $lang = 'cy' if $host =~ /cy/; - $lang = 'en-gb' if $host =~ /^en\./; - Cobrand::set_lang_and_domain(get_cobrand($q), $lang, 1); - - FixMyStreet::Map::set_map_class($q->param('map')); - - Problems::set_site_restriction($q); - Memcached::set_namespace(mySociety::Config::get('BCI_DB_NAME') . ":"); -} -=item get_cobrand Q - -Return the cobrand for a query - -=cut -sub get_cobrand { - my $q = shift; - my $cobrand = ''; - $cobrand = $q->{site} if $q->{site} ne 'fixmystreet'; - return $cobrand; -} - -=item base_url_with_lang Q REVERSE EMAIL - -Return the base URL for the site. Reverse the language component if REVERSE is set to one. If EMAIL is set to -one, return the base URL to use in emails. - -=cut - -sub base_url_with_lang { - my ($q, $reverse, $email) = @_; - my $base; - my $cobrand = get_cobrand($q); - if ($email) { - $base = Cobrand::base_url_for_emails($cobrand, Cobrand::extra_data($cobrand, $q)); - } else { - $base = Cobrand::base_url($cobrand); - } - return $base unless $q->{site} eq 'emptyhomes'; - my $lang = $mySociety::Locale::lang; - if ($reverse && $lang eq 'en-gb') { - $base =~ s{http://}{$&cy.}; - } elsif ($reverse) { - $base =~ s{http://}{$&en.}; - } elsif ($lang eq 'cy') { - $base =~ s{http://}{$&cy.}; - } else { - $base =~ s{http://}{$&en.}; - } - return $base; -} - -=item template_root - -Returns the path from which template files will be read. - -=cut - -sub template_root($;$) { - my ($q, $fallback) = @_; - return '/../templates/website/' if $q->{site} eq 'fixmystreet' || $fallback; - return '/../templates/website/cobrands/' . $q->{site} . '/'; -} - -=item template_vars QUERY PARAMS - -Return a hash of variables that can be substituted into header and footer templates. -QUERY is the incoming request -PARAMS contains a few things used to generate variables, such as lang, title, and rss. - -=cut - -sub template_vars ($%) { - my ($q, %params) = @_; - my %vars; - my $host = base_url_with_lang($q, undef); - my $lang_url = base_url_with_lang($q, 1); - $lang_url .= $ENV{REQUEST_URI} if $ENV{REQUEST_URI}; - - my $site_title = Cobrand::site_title(get_cobrand($q)); - $site_title = _('FixMyStreet') unless $site_title; - - %vars = ( - 'report' => _('Report a problem'), - 'reports' => _('All reports'), - 'alert' => _('Local alerts'), - 'faq' => _('Help'), - 'about' => _('About us'), - 'site_title' => $site_title, - 'host' => $host, - 'lang_code' => $params{lang}, - 'lang' => $params{lang} eq 'en-gb' ? 'Cymraeg' : 'English', - 'lang_url' => $lang_url, - 'title' => $params{title}, - 'rss' => '', - map_js => $params{js} || '', - ); - - if ($params{rss}) { - $vars{rss} = '<link rel="alternate" type="application/rss+xml" title="' . $params{rss}[0] . '" href="' . $params{rss}[1] . '">'; - } - - if ($params{robots}) { - $vars{robots} = '<meta name="robots" content="' . $params{robots} . '">'; - } - - my $home = !$params{title} && $ENV{SCRIPT_NAME} eq '/index.cgi' && !$ENV{QUERY_STRING}; - $vars{heading_element_start} = $home ? '<h1 id="header">' : '<div id="header"><a href="/">'; - $vars{heading} = _('Fix<span id="my">My</span>Street'); - $vars{heading_element_end} = $home ? '</h1>' : '</a></div>'; - - return \%vars; -} - -=item template Q [PARAM VALUE ...] - -Return the correct template given PARAMs - -=cut -sub template($%){ - my ($q, %params) = @_; - my $template; - if ($params{template}){ - $template = $params{template}; - }else{ - $template = $q->{site}; - } - return $template; -} - -=item template_include - -Return HTML for a template, given a template name, request, -template root, and any parameters needed. - -=cut - -sub template_include { - my ($template, $q, $template_root, %params) = @_; - (my $file = __FILE__) =~ s{/[^/]*?$}{}; - my $template_file = $file . $template_root . $template; - $template_file = $file . template_root($q, 1) . $template unless -e $template_file; - return undef unless -e $template_file; - - $template = Text::Template->new( - TYPE => 'STRING', - # Don't use FILE, because we need to make sure it's Unicode characters - SOURCE => decode_utf8(File::Slurp::read_file($template_file)), - DELIMITERS => ['{{', '}}'], - ); - return $template->fill_in(HASH => \%params); -} - -=item header Q [PARAM VALUE ...] - -Return HTML for the top of the page, given PARAMs (TITLE is required). - -=cut -sub header ($%) { - my ($q, %params) = @_; - my $context = $params{context}; - my $default_params = Cobrand::header_params(get_cobrand($q), $q, %params); - my %default_params = %{$default_params}; - %params = (%default_params, %params); - my %permitted_params = map { $_ => 1 } qw(title rss expires lastmodified template cachecontrol context status_code robots js); - foreach (keys %params) { - croak "bad parameter '$_'" if (!exists($permitted_params{$_})); - } - - my %head = (); - $head{-expires} = $params{expires} if $params{expires}; - $head{'-last-modified'} = time2str($params{lastmodified}) if $params{lastmodified}; - $head{'-last-modified'} = time2str($lastmodified) if $lastmodified; - $head{'-Cache-Control'} = $params{cachecontrol} if $params{cachecontrol}; - $head{'-status'} = $params{status_code} if $params{status_code}; - print $q->header(%head); - - $params{title} ||= ''; - $params{title} .= ' - ' if $params{title}; - $params{title} = ent($params{title}); - $params{lang} = $mySociety::Locale::lang; - - my $vars = template_vars($q, %params); - my $html = template_include('header', $q, template_root($q), %$vars); - my $cache_val = $default_params{cachecontrol}; - if (mySociety::Config::get('STAGING_SITE')) { - $html .= '<p class="error">' . _("This is a developer site; things might break at any time, and the database will be periodically deleted.") . '</p>'; - } - return $html; -} - -=item footer - -=cut -sub footer { - my ($q, %params) = @_; - - my $pc = $q->param('pc') || ''; - $pc = '?pc=' . URI::Escape::uri_escape_utf8($pc) if $pc; - - my $creditline = _('Built by <a href="http://www.mysociety.org/">mySociety</a>, using some <a href="http://github.com/mysociety/fixmystreet">clever</a> <a href="https://secure.mysociety.org/cvstrac/dir?d=mysociety/services/TilMa">code</a>.'); - if (mySociety::Config::get('COUNTRY') eq 'NO') { - $creditline = _('Built by <a href="http://www.mysociety.org/">mySociety</a> and maintained by <a href="http://www.nuug.no/">NUUG</a>, using some <a href="http://github.com/mysociety/fixmystreet">clever</a> <a href="https://secure.mysociety.org/cvstrac/dir?d=mysociety/services/TilMa">code</a>.'); - } - - %params = (%params, - navigation => _('Navigation'), - report => _("Report a problem"), - reports => _("All reports"), - alerts => _("Local alerts"), - help => _("Help"), - contact => _("Contact"), - pc => $pc, - orglogo => _('<a href="http://www.mysociety.org/"><img id="logo" width="133" height="26" src="/i/mysociety-dark.png" alt="View mySociety.org"><span id="logoie"></span></a>'), - creditline => $creditline, - ); - - my $html = template_include('footer', $q, template_root($q), %params); - if ($html) { - my $lang = $mySociety::Locale::lang; - if ($q->{site} eq 'emptyhomes' && $lang eq 'cy') { - $html =~ s/25 Walter Road<br>Swansea/25 Heol Walter<br>Abertawe/; - } - return $html; - } - - my $piwik = ""; - if (mySociety::Config::get('BASE_URL') eq "http://www.fixmystreet.com") { - $piwik = <<EOF; -<!-- Piwik --> -<script type="text/javascript"> -var pkBaseURL = (("https:" == document.location.protocol) ? "https://piwik.mysociety.org/" : "http://piwik.mysociety.org/"); -document.write(unescape("%3Cscript src='" + pkBaseURL + "piwik.js' type='text/javascript'%3E%3C/script%3E")); -</script><script type="text/javascript"> -try { -var piwikTracker = Piwik.getTracker(pkBaseURL + "piwik.php", 8); -piwikTracker.trackPageView(); -piwikTracker.enableLinkTracking(); -} catch( err ) {} -</script><noscript><p><img src="http://piwik.mysociety.org/piwik.php?idsite=8" style="border:0" alt=""/></p></noscript> -<!-- End Piwik Tag --> -EOF - } - - return <<EOF; -</div></div> -<h2 class="v">$params{navigation}</h2> -<ul id="navigation"> -<li><a href="/">$params{report}</a></li> -<li><a href="/reports">$params{reports}</a></li> -<li><a href="/alert$params{pc}">$params{alerts}</a></li> -<li><a href="/faq">$params{help}</a></li> -<li><a href="/contact">$params{contact}</a></li> -</ul> - -$params{orglogo} - -<p id="footer">$params{creditline}</p> - -$piwik - -</body> -</html> -EOF -} - -=item error_page Q MESSAGE - -=cut -sub error_page ($$) { - my ($q, $message); - my $html = header($q, title=>_("Error")) - . $q->p($message) - . footer($q); - print $q->header(-content_length => length($html)), $html; -} - -# send_email TO (NAME) TEMPLATE-NAME PARAMETERS -# TEMPLATE-NAME is a full filename here. -sub send_email { - my ($q, $recipient_email_address, $name, $template, %h) = @_; - - $template = File::Slurp::read_file("$FindBin::Bin/../templates/emails/$template"); - my $to = $name ? [[$recipient_email_address, $name]] : $recipient_email_address; - my $cobrand = get_cobrand($q); - my $sender = Cobrand::contact_email($cobrand); - my $sender_name = Cobrand::contact_name($cobrand); - $sender =~ s/team/fms-DO-NOT-REPLY/; - - # Can send email either via EvEl (if configured) or via local MTA on - # machine. If EvEl fails (server down etc) fall back to local sending - - my $email_building_args = { - _template_ => _($template), - _parameters_ => \%h, - From => [ $sender, _($sender_name) ], - To => $to, - }; - - my $email_sent_successfully = 0; - - if ( my $EvEl_url = mySociety::Config::get('EVEL_URL') ) { - eval { - mySociety::EvEl::send( $email_building_args, $recipient_email_address ); - $email_sent_successfully = 1; - }; - - warn "ERROR: sending email via '$EvEl_url' failed: $@" if $@; - } - - # If not sent through EvEL, or EvEl failed - if ( !$email_sent_successfully ) { - my $email = mySociety::Locale::in_gb_locale { - mySociety::Email::construct_email( $email_building_args ); - }; - - my $send_email_result = - mySociety::EmailUtil::send_email( $email, $sender, $recipient_email_address ); - $email_sent_successfully = !$send_email_result; # invert result - } - - # Could not send email - die - if ( !$email_sent_successfully ) { - throw Error::Simple( - "Could not send email to '$recipient_email_address' " - . "using either EvEl or local MTA." - ); - } - -} - -# send_confirmation_email TO (NAME) TEMPLATE-NAME PARAMETERS -# TEMPLATE-NAME is currently one of problem, update, alert, tms -sub send_confirmation_email { - my ($q, $recipient_email_address, $name, $thing, %h) = @_; - - my $file_thing = $thing; - $file_thing = 'empty property' if $q->{site} eq 'emptyhomes' && $thing eq 'problem'; # Needs to be in English - my $template = "$file_thing-confirm"; - - send_email($q, $recipient_email_address, $name, $template, %h); - - my ($action, $worry); - if ($thing eq 'problem') { - $action = _('your problem will not be posted'); - $worry = _("we'll hang on to your problem report while you're checking your email."); - } elsif ($thing eq 'update') { - $action = _('your update will not be posted'); - $worry = _("we'll hang on to your update while you're checking your email."); - } elsif ($thing eq 'alert') { - $action = _('your alert will not be activated'); - $worry = _("we'll hang on to your alert while you're checking your email."); - } elsif ($thing eq 'tms') { - $action = 'your expression of interest will not be registered'; - $worry = "we'll hang on to your expression of interest while you're checking your email."; - } - - my $out = sprintf(_(<<EOF), $action, $worry); -<h1>Nearly Done! Now check your email...</h1> -<p>The confirmation email <strong>may</strong> take a few minutes to arrive — <em>please</em> be patient.</p> -<p>If you use web-based email or have 'junk mail' filters, you may wish to check your bulk/spam mail folders: sometimes, our messages are marked that way.</p> -<p>You must now click the link in the email we've just sent you — -if you do not, %s.</p> -<p>(Don't worry — %s)</p> -EOF - - my $cobrand = get_cobrand($q); - my %vars = ( - action => $action, - worry => $worry, - url_home => Cobrand::url($cobrand, '/', $q), - ); - my $cobrand_email = Page::template_include('check-email', $q, Page::template_root($q), %vars); - return $cobrand_email if $cobrand_email; - return $out; -} - -sub prettify_epoch { - my ($q, $s, $short) = @_; - my $cobrand = get_cobrand($q); - my $cobrand_datetime = Cobrand::prettify_epoch($cobrand, $s); - return $cobrand_datetime if ($cobrand_datetime); - my @s = localtime($s); - my $tt = strftime('%H:%M', @s); - my @t = localtime(); - if (strftime('%Y%m%d', @s) eq strftime('%Y%m%d', @t)) { - $tt = "$tt " . _('today'); - } elsif (strftime('%Y %U', @s) eq strftime('%Y %U', @t)) { - $tt = "$tt, " . decode_utf8(strftime('%A', @s)); - } elsif ($short) { - $tt = "$tt, " . decode_utf8(strftime('%e %b %Y', @s)); - } elsif (strftime('%Y', @s) eq strftime('%Y', @t)) { - $tt = "$tt, " . decode_utf8(strftime('%A %e %B %Y', @s)); - } else { - $tt = "$tt, " . decode_utf8(strftime('%a %e %B %Y', @s)); - } - return $tt; -} - -# argument is duration in seconds, rounds to the nearest minute -sub prettify_duration { - my ($s, $nearest) = @_; - if ($nearest eq 'week') { - $s = int(($s+60*60*24*3.5)/60/60/24/7)*60*60*24*7; - } elsif ($nearest eq 'day') { - $s = int(($s+60*60*12)/60/60/24)*60*60*24; - } elsif ($nearest eq 'hour') { - $s = int(($s+60*30)/60/60)*60*60; - } elsif ($nearest eq 'minute') { - $s = int(($s+30)/60)*60; - return _('less than a minute') if $s == 0; - } - my @out = (); - _part(\$s, 60*60*24*7, _('%d week'), _('%d weeks'), \@out); - _part(\$s, 60*60*24, _('%d day'), _('%d days'), \@out); - _part(\$s, 60*60, _('%d hour'), _('%d hours'), \@out); - _part(\$s, 60, _('%d minute'), _('%d minutes'), \@out); - return join(', ', @out); -} -sub _part { - my ($s, $m, $w1, $w2, $o) = @_; - if ($$s >= $m) { - my $i = int($$s / $m); - push @$o, sprintf(mySociety::Locale::nget($w1, $w2, $i), $i); - $$s -= $i * $m; - } -} - -sub display_problem_meta_line($$) { - my ($q, $problem) = @_; - my $out = ''; - my $date_time = prettify_epoch($q, $problem->{time}); - if ($q->{site} eq 'emptyhomes') { - my $category = _($problem->{category}); - utf8::decode($category); # So that Welsh to Welsh doesn't encode already-encoded UTF-8 - if ($problem->{anonymous}) { - $out .= sprintf(_('%s, reported anonymously at %s'), ent($category), $date_time); - } else { - $out .= sprintf(_('%s, reported by %s at %s'), ent($category), ent($problem->{name}), $date_time); - } - } else { - if ($problem->{service} && $problem->{category} && $problem->{category} ne _('Other') && $problem->{anonymous}) { - $out .= sprintf(_('Reported by %s in the %s category anonymously at %s'), ent($problem->{service}), ent($problem->{category}), $date_time); - } elsif ($problem->{service} && $problem->{category} && $problem->{category} ne _('Other')) { - $out .= sprintf(_('Reported by %s in the %s category by %s at %s'), ent($problem->{service}), ent($problem->{category}), ent($problem->{name}), $date_time); - } elsif ($problem->{service} && $problem->{anonymous}) { - $out .= sprintf(_('Reported by %s anonymously at %s'), ent($problem->{service}), $date_time); - } elsif ($problem->{service}) { - $out .= sprintf(_('Reported by %s by %s at %s'), ent($problem->{service}), ent($problem->{name}), $date_time); - } elsif ($problem->{category} && $problem->{category} ne _('Other') && $problem->{anonymous}) { - $out .= sprintf(_('Reported in the %s category anonymously at %s'), ent($problem->{category}), $date_time); - } elsif ($problem->{category} && $problem->{category} ne _('Other')) { - $out .= sprintf(_('Reported in the %s category by %s at %s'), ent($problem->{category}), ent($problem->{name}), $date_time); - } elsif ($problem->{anonymous}) { - $out .= sprintf(_('Reported anonymously at %s'), $date_time); - } else { - $out .= sprintf(_('Reported by %s at %s'), ent($problem->{name}), $date_time); - } - } - my $cobrand = get_cobrand($q); - $out .= Cobrand::extra_problem_meta_text($cobrand, $problem); - $out .= '; ' . _('the map was not used so pin location may be inaccurate') unless ($problem->{used_map}); - if ($problem->{council}) { - if ($problem->{whensent}) { - my $body; - if ($problem->{external_body}) { - $body = $problem->{external_body}; - } else { - $problem->{council} =~ s/\|.*//g; - my @councils = split /,/, $problem->{council}; - my $areas_info = mySociety::MaPit::call('areas', \@councils); - $body = join(' and ', map { $areas_info->{$_}->{name} } @councils); - } - $out .= '<small class="council_sent_info">'; - $out .= $q->br() . sprintf(_('Sent to %s %s later'), $body, prettify_duration($problem->{whensent}, 'minute')); - $out .= '</small>'; - } - } else { - $out .= $q->br() . $q->small(_('Not reported to council')); - } - return $out; -} - -sub display_problem_detail($) { - my $problem = shift; - (my $detail = $problem->{detail}) =~ s/\r//g; - my $out = ''; - foreach (split /\n{2,}/, $detail) { - my $enttext = $_; - $enttext =~ s%(https?://[^\s]+)%<a href="$1">$1</a>%g; - $out .= '<p>' . $enttext . '</p>'; - } - return $out; -} - -sub display_problem_photo($$) { - my ($q, $problem) = @_; - my $cobrand = get_cobrand($q); - my $display_photos = Cobrand::allow_photo_display($cobrand); - if ($display_photos && $problem->{photo}) { - my $dims = Image::Size::html_imgsize(\$problem->{photo}); - return "<p align='center'><img alt='' $dims src='/photo?id=$problem->{id}'></p>"; - } - return ''; -} - -# Display information about problem -sub display_problem_text($$) { - my ($q, $problem) = @_; - - my $out = $q->h1(ent($problem->{title})); - $out .= '<p><em>'; - $out .= display_problem_meta_line($q, $problem); - $out .= '</em></p>'; - $out .= display_problem_detail($problem); - $out .= display_problem_photo($q, $problem); - return $out; -} - -# Display updates -sub display_problem_updates($$) { - my ($id, $q) = @_; - my $cobrand = get_cobrand($q); - my $updates = select_all( - "select id, name, extract(epoch from confirmed) as confirmed, text, - mark_fixed, mark_open, photo, cobrand - from comment where problem_id = ? and state='confirmed' - order by confirmed", $id); - my $out = ''; - if (@$updates) { - $out .= '<div id="updates">'; - $out .= '<h2 class="problem-update-list-header">' . _('Updates') . '</h2>'; - foreach my $row (@$updates) { - $out .= "<div><div class=\"problem-update\"><p><a name=\"update_$row->{id}\"></a><em>"; - if ($row->{name}) { - $out .= sprintf(_('Posted by %s at %s'), ent($row->{name}), prettify_epoch($q, $row->{confirmed})); - } else { - $out .= sprintf(_('Posted anonymously at %s'), prettify_epoch($q, $row->{confirmed})); - } - $out .= Cobrand::extra_update_meta_text($cobrand, $row); - $out .= ', ' . _('marked as fixed') if ($row->{mark_fixed}); - $out .= ', ' . _('reopened') if ($row->{mark_open}); - $out .= '</em></p>'; - - my $allow_update_reporting = Cobrand::allow_update_reporting($cobrand); - if ($allow_update_reporting) { - my $contact = '/contact?id=' . $id . ';update_id='. $row->{id}; - my $contact_url = Cobrand::url($cobrand, $contact, $q); - $out .= '<p>'; - $out .= $q->a({rel => 'nofollow', class => 'unsuitable-problem', href => $contact_url}, _('Offensive? Unsuitable? Tell us')); - $out .= '</p>'; - } - $out .= '</div>'; - $out .= '<div class="update-text">'; - my $text = $row->{text}; - $text =~ s/\r//g; - foreach (split /\n{2,}/, $text) { - my $enttext = ent($_); - $enttext =~ s%(https?://[^\s]+)%<a href="$1">$1</a>%g; - $out .= '<p>' . $enttext . '</p>'; - } - my $cobrand = get_cobrand($q); - my $display_photos = Cobrand::allow_photo_display($cobrand); - if ($display_photos && $row->{photo}) { - my $dims = Image::Size::html_imgsize(\$row->{photo}); - $out .= "<p><img alt='' $dims src='/photo?c=$row->{id}'></p>"; - } - $out .= '</div>'; - $out .= '</div>'; - } - $out .= '</div>'; - } - return $out; -} - -sub mapit_check_error { - my $location = shift; - if ($location->{error}) { - return _('That postcode was not recognised, sorry.') if $location->{code} =~ /^4/; - return $location->{error}; - } - if (mySociety::Config::get('COUNTRY') eq 'GB') { - my $island = $location->{coordsyst}; - if (!$island) { - return _("Sorry, that appears to be a Crown dependency postcode, which we don't cover."); - } - if ($island eq 'I') { - return _("We do not cover Northern Ireland, I'm afraid, as our licence doesn't include any maps for the region."); - } - } - return 0; -} - -sub short_name { - my ($area, $info) = @_; - # Special case Durham as it's the only place with two councils of the same name - # And some places in Norway - return 'Durham+County' if $area->{name} eq 'Durham County Council'; - return 'Durham+City' if $area->{name} eq 'Durham City Council'; - if ($area->{name} =~ /^(Os|Nes|V\xe5ler|Sande|B\xf8|Her\xf8y)$/) { - my $parent = $info->{$area->{parent_area}}->{name}; - return URI::Escape::uri_escape_utf8("$area->{name}, $parent"); - } - my $name = $area->{name}; - $name =~ s/ (Borough|City|District|County) Council$//; - $name =~ s/ Council$//; - $name =~ s/ & / and /; - $name = URI::Escape::uri_escape_utf8($name); - $name =~ s/%20/+/g; - return $name; -} - -sub check_photo { - my ($q, $fh) = @_; - my $ct = $q->uploadInfo($fh)->{'Content-Type'}; - my $cd = $q->uploadInfo($fh)->{'Content-Disposition'}; - # Must delete photo param, otherwise display functions get confused - $q->delete('photo'); - return _('Please upload a JPEG image only') unless - ($ct eq 'image/jpeg' || $ct eq 'image/pjpeg'); - return ''; -} - -sub process_photo { - my $fh = shift; - my $import = shift; - - my $blob = join('', <$fh>); - close $fh; - my ($handle, $filename) = mySociety::TempFiles::named_tempfile('.jpeg'); - print $handle $blob; - close $handle; - - my $photo = Image::Magick->new; - my $err = $photo->Read($filename); - unlink $filename; - throw Error::Simple("read failed: $err") if "$err"; - $err = $photo->Scale(geometry => "250x250>"); - throw Error::Simple("resize failed: $err") if "$err"; - my @blobs = $photo->ImageToBlob(); - undef $photo; - $photo = $blobs[0]; - return $photo unless $import; # Only check orientation for iPhone imports at present - - # Now check if it needs orientating - ($fh, $filename) = mySociety::TempFiles::named_tempfile('.jpeg'); - print $fh $photo; - close $fh; - my $out = `jhead -se -autorot $filename`; - if ($out) { - open(FP, $filename) or throw Error::Simple($!); - $photo = join('', <FP>); - close FP; - } - unlink $filename; - return $photo; -} - -sub scambs_categories { - return ('Abandoned vehicles', 'Discarded hypodermic needles', - 'Dog fouling', 'Flytipping', 'Graffiti', 'Lighting (e.g. security lights)', - 'Litter', 'Neighbourhood noise'); -} - -1; diff --git a/perllib/Problems.pm b/perllib/Problems.pm deleted file mode 100644 index 7155aa485..000000000 --- a/perllib/Problems.pm +++ /dev/null @@ -1,589 +0,0 @@ -#!/usr/bin/perl -# -# Problems.pm: -# Various problem report database fetching related functions for FixMyStreet. -# -# Copyright (c) 2008 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ -# -# $Id: Problems.pm,v 1.33 2010-01-20 11:09:45 matthew Exp $ -# - -package Problems; - -use strict; -use Encode; -use Memcached; -use mySociety::DBHandle qw/dbh select_all/; -use mySociety::Locale; -use mySociety::Web qw/ent/; -use mySociety::MaPit; - -my $site_restriction = ''; -my $site_key = 0; - -sub set_site_restriction { - my $q = shift; - my $site = $q->{site}; - if ($site ne 'fixmystreet'){ - my $cobrand = Page::get_cobrand($q); - my $cobrand_data = Cobrand::extra_data($cobrand, $q); - ($site_restriction, $site_key) = Cobrand::site_restriction($cobrand, $cobrand_data); - } else { - $site_restriction = ''; - $site_key = 0; - } -} - -sub current_timestamp { - my $current_timestamp = dbh()->selectrow_array('select ms_current_timestamp()'); - return "'$current_timestamp'::timestamp"; -} - -# Front page statistics - -sub recent_fixed { - my $key = "recent_fixed:$site_key"; - my $result = Memcached::get($key); - unless ($result) { - $result = dbh()->selectrow_array("select count(*) from problem - where state='fixed' and lastupdate>" . current_timestamp() . "-'1 month'::interval - $site_restriction"); - Memcached::set($key, $result, 3600); - } - return $result; -} - -sub number_comments { - my $key = "number_comments:$site_key"; - my $result = Memcached::get($key); - unless ($result) { - if ($site_restriction) { - $result = dbh()->selectrow_array("select count(*) from comment, problem - where comment.problem_id=problem.id and comment.state='confirmed' - $site_restriction"); - } else { - $result = dbh()->selectrow_array("select count(*) from comment - where state='confirmed'"); - } - Memcached::set($key, $result, 3600); - } - return $result; -} - -sub recent_new { - my $interval = shift; - (my $key = $interval) =~ s/\s+//g; - $key = "recent_new:$site_key:$key"; - my $result = Memcached::get($key); - unless ($result) { - $result = dbh()->selectrow_array("select count(*) from problem - where state in ('confirmed','fixed') and confirmed>" . current_timestamp() . "-'$interval'::interval - $site_restriction"); - Memcached::set($key, $result, 3600); - } - return $result; -} - -# Front page recent lists - -sub recent_photos { - my ($num, $lat, $lon, $dist) = @_; - my $probs; - if (defined $lat) { - my $dist2 = $dist; # Create a copy of the variable to stop it being stringified into a locale in the next line! - my $key = "recent_photos:$site_key:$num:$lat:$lon:$dist2"; - $probs = Memcached::get($key); - unless ($probs) { - $probs = mySociety::Locale::in_gb_locale { - select_all("select id, title - from problem_find_nearby(?, ?, ?) as nearby, problem - where nearby.problem_id = problem.id - and state in ('confirmed', 'fixed') and photo is not null - $site_restriction - order by confirmed desc limit $num", $lat, $lon, $dist); - }; - Memcached::set($key, $probs, 3600); - } - } else { - my $key = "recent_photos:$site_key:$num"; - $probs = Memcached::get($key); - unless ($probs) { - $probs = select_all("select id, title from problem - where state in ('confirmed', 'fixed') and photo is not null - $site_restriction - order by confirmed desc limit $num"); - Memcached::set($key, $probs, 3600); - } - } - my $out = ''; - foreach (@$probs) { - my $title = ent($_->{title}); - $out .= '<a href="/report/' . $_->{id} . - '"><img border="0" height="100" src="/photo?tn=1;id=' . $_->{id} . - '" alt="' . $title . '" title="' . $title . '"></a>'; - } - return $out; -} - -sub recent { - my $key = "recent:$site_key"; - my $result = Memcached::get($key); - unless ($result) { - $result = select_all("select id,title from problem - where state in ('confirmed', 'fixed') - $site_restriction - order by confirmed desc limit 5"); - Memcached::set($key, $result, 3600); - } - return $result; -} - -sub front_stats { - my ($q) = @_; - my $fixed = Problems::recent_fixed(); - my $updates = Problems::number_comments(); - my $new = Problems::recent_new('1 week'); - (my $new_pretty = $new) =~ s/(?<=\d)(?=(?:\d\d\d)+$)/,/g; - my $new_text = sprintf(mySociety::Locale::nget('<big>%s</big> report in past week', - '<big>%s</big> reports in past week', $new), $new_pretty); - if ($q->{site} ne 'emptyhomes' && $new > $fixed) { - $new = Problems::recent_new('3 days'); - ($new_pretty = $new) =~ s/(?<=\d)(?=(?:\d\d\d)+$)/,/g; - $new_text = sprintf(mySociety::Locale::nget('<big>%s</big> report recently', '<big>%s</big> reports recently', $new), $new_pretty); - } - (my $fixed_pretty = $fixed) =~ s/(?<=\d)(?=(?:\d\d\d)+$)/,/g; - (my $updates_pretty = $updates) =~ s/(?<=\d)(?=(?:\d\d\d)+$)/,/g; - - my $out = ''; - $out .= $q->h2(_('FixMyStreet updates')); - my $lastmo = ''; - if ($q->{site} ne 'emptyhomes'){ - $lastmo = $q->div(sprintf(mySociety::Locale::nget("<big>%s</big> fixed in past month", "<big>%s</big> fixed in past month", $fixed), $fixed), $fixed_pretty); - } - $out .= $q->div({-id => 'front_stats'}, - $q->div($new_text), - ($q->{site} ne 'emptyhomes' ? $q->div(sprintf(mySociety::Locale::nget("<big>%s</big> fixed in past month", "<big>%s</big> fixed in past month", $fixed), $fixed_pretty)) : ''), - $q->div(sprintf(mySociety::Locale::nget("<big>%s</big> update on reports", - "<big>%s</big> updates on reports", $updates), $updates_pretty)) - ); - return $out; - -} - -# Problems around a location - -sub around_map { - my ($min_lat, $max_lat, $min_lon, $max_lon, $interval, $limit) = @_; - my $limit_clause = ''; - if ($limit) { - $limit_clause = " limit $limit"; - } - mySociety::Locale::in_gb_locale { select_all( - "select id,title,latitude,longitude,state, - extract(epoch from confirmed) as time - from problem - where state in ('confirmed', 'fixed') - and latitude>=? and latitude<? and longitude>=? and longitude<? " . - ($interval ? " and ms_current_timestamp()-lastupdate < '$interval'::interval" : '') . - " $site_restriction - order by created desc - $limit_clause", $min_lat, $max_lat, $min_lon, $max_lon); - }; -} - -sub nearby { - my ($dist, $ids, $limit, $mid_lat, $mid_lon, $interval) = @_; - mySociety::Locale::in_gb_locale { select_all( - "select id, title, latitude, longitude, distance, state, - extract(epoch from confirmed) as time - from problem_find_nearby(?, ?, $dist) as nearby, problem - where nearby.problem_id = problem.id " . - ($interval ? " and ms_current_timestamp()-lastupdate < '$interval'::interval" : '') . - " and state in ('confirmed', 'fixed')" . ($ids ? ' and id not in (' . $ids . ')' : '') . " - $site_restriction - order by distance, created desc limit $limit", $mid_lat, $mid_lon); - } -} - -sub fixed_nearby { - my ($dist, $mid_lat, $mid_lon) = @_; - mySociety::Locale::in_gb_locale { select_all( - "select id, title, latitude, longitude, distance - from problem_find_nearby(?, ?, $dist) as nearby, problem - where nearby.problem_id = problem.id and state='fixed' - $site_restriction - order by lastupdate desc", $mid_lat, $mid_lon); - } -} - -# Fetch an individual problem - -sub fetch_problem { - my $id = shift; - my $p = dbh()->selectrow_hashref( - "select id, latitude, longitude, council, category, title, detail, photo, - used_map, name, anonymous, extract(epoch from confirmed) as time, - state, extract(epoch from whensent-confirmed) as whensent, - extract(epoch from ms_current_timestamp()-lastupdate) as duration, - service, cobrand, cobrand_data, external_body - from problem where id=? and state in ('confirmed','fixed', 'hidden') - $site_restriction", {}, $id - ); - $p->{service} =~ s/_/ /g if $p && $p->{service}; - return $p; -} - -# API functions - -sub problems_matching_criteria { - my ($criteria, @params) = @_; - my $problems = select_all( - "select id, title, council, category, detail, name, anonymous, - confirmed, whensent, service - from problem - $criteria - $site_restriction", @params); - - my @councils; - foreach my $problem (@$problems){ - if ($problem->{anonymous} == 1){ - $problem->{name} = ''; - } - if ($problem->{service} eq ''){ - $problem->{service} = 'Web interface'; - } - if ($problem->{council}) { - $problem->{council} =~ s/\|.*//g; - my @council_ids = split /,/, $problem->{council}; - push(@councils, @council_ids); - $problem->{council} = \@council_ids; - } - } - my $areas_info = mySociety::MaPit::call('areas', \@councils); - foreach my $problem (@$problems){ - if ($problem->{council}) { - my @council_names = map { $areas_info->{$_}->{name} } @{$problem->{council}} ; - $problem->{council} = join(' and ', @council_names); - } - } - return $problems; -} - -sub fixed_in_interval { - my ($start_date, $end_date) = @_; - my $criteria = "where state='fixed' and date_trunc('day',lastupdate)>=? and -date_trunc('day',lastupdate)<=?"; - return problems_matching_criteria($criteria, $start_date, $end_date); -} - -sub created_in_interval { - my ($start_date, $end_date) = @_; - my $criteria = "where state='confirmed' and date_trunc('day',created)>=? and -date_trunc('day',created)<=?"; - return problems_matching_criteria($criteria, $start_date, $end_date); -} - -=item data_sharing_notification_start - -Returns the unix datetime when the T&Cs that explicitly allow for users' data to be displayed -on other sites. - -=cut - -sub data_sharing_notification_start { - return 1255392000; -} - -# Report functions - -=item council_problems WARD COUNCIL - -Returns a list of problems for a summary page. If WARD or COUNCIL area ids are given, -will only return problems for that area. Uses any site restriction defined by the -cobrand. - -=cut - -sub council_problems { - my ($ward, $one_council) = @_; - my @params; - my $where_extra = ''; - if ($ward) { - push @params, $ward; - $where_extra = "and areas like '%,'||?||',%'"; - } elsif ($one_council) { - push @params, $one_council; - $where_extra = "and areas like '%,'||?||',%'"; - } - my $current_timestamp = current_timestamp(); - my $problems = select_all( - "select id, title, detail, council, state, areas, - extract(epoch from $current_timestamp-lastupdate) as duration, - extract(epoch from $current_timestamp-confirmed) as age - from problem - where state in ('confirmed', 'fixed') - $where_extra - $site_restriction - order by id desc - ", @params); - return $problems; -} - -# Admin view functions - -=item problem_search SEARCH - -Returns all problems containing the search term in their name, email, title, -detail or council, or whose ID is the search term. Uses any site_restriction -defined by a cobrand. - -=cut -sub problem_search { - my ($search) = @_; - my $search_n = 0; - $search_n = int($search) if $search =~ /^\d+$/; - my $problems = select_all("select id, council, category, title, name, - email, anonymous, cobrand, cobrand_data, created, confirmed, state, service, lastupdate, - whensent, send_questionnaire from problem where (id=? or email ilike - '%'||?||'%' or name ilike '%'||?||'%' or title ilike '%'||?||'%' or - detail ilike '%'||?||'%' or council like '%'||?||'%' or cobrand_data like '%'||?||'%') - $site_restriction - order by (state='hidden'),created", $search_n, - $search, $search, $search, $search, $search, $search); - return $problems; -} - -=item update_search SEARCH - -Returns all updates containing the search term in their name, email or text, or whose ID -is the search term. Uses any site_restriction defined by a cobrand. - -=cut -sub update_search { - my ($search) = @_; - my $search_n = 0; - $search_n = int($search) if $search =~ /^\d+$/; - my $updates = select_all("select comment.*, problem.council, problem.state as problem_state - from comment, problem where problem.id = comment.problem_id - and (comment.id=? or - problem_id=? or comment.email ilike '%'||?||'%' or comment.name ilike '%'||?||'%' or - comment.text ilike '%'||?||'%' or comment.cobrand_data ilike '%'||?||'%') - $site_restriction - order by (comment.state='hidden'),(problem.state='hidden'),created", $search_n, $search_n, $search, $search, - $search, $search); - return $updates; -} - -=item update_counts - -An array reference of updates grouped by state. Uses any site_restriction defined by a cobrand. - -=cut - -sub update_counts { - return dbh()->selectcol_arrayref("select comment.state, count(comment.*) as c from comment, problem - where problem.id = comment.problem_id - $site_restriction - group by comment.state", { Columns => [1,2] }); -} - -=item problem_counts - -An array reference of problems grouped by state. Uses any site_restriction defined by a cobrand. - -=cut - -sub problem_counts { - return dbh()->selectcol_arrayref("select state, count(*) as c from problem - where id=id $site_restriction - group by state", { Columns => [1,2] }); -} - -=item - -An array reference of alerts grouped by state (specific to the cobrand if there is one). - -=cut - -sub alert_counts { - my ($cobrand) = @_; - my $cobrand_clause = ''; - if ($cobrand) { - $cobrand_clause = " where cobrand = '$cobrand'"; - } - return dbh()->selectcol_arrayref("select confirmed, count(*) as c - from alert - $cobrand_clause - group by confirmed", { Columns => [1,2] }); -} - -=item questionnaire_counts - -An array reference of questionnaires. Restricted to questionnaires related to -problems submitted through the cobrand if a cobrand is specified. - -=cut -sub questionnaire_counts { - my ($cobrand) = @_; - my $cobrand_clause = ''; - if ($cobrand) { - $cobrand_clause = " and cobrand = '$cobrand'"; - } - my $questionnaires = dbh()->selectcol_arrayref("select (whenanswered is not null), count(questionnaire.*) as c - from questionnaire, problem - where problem.id = questionnaire.problem_id - $cobrand_clause - group by (whenanswered is not null)", { Columns => [1,2] }); - return $questionnaires; -} - -=item contact_counts COBRAND - -An array reference of contacts. Restricted to contacts relevant to -the cobrand if a cobrand is specified. - -=cut -sub contact_counts { - my ($cobrand) = @_; - my $contact_restriction = Cobrand::contact_restriction($cobrand); - my $contacts = dbh()->selectcol_arrayref("select confirmed, count(*) as c from contacts $contact_restriction group by confirmed", { Columns => [1,2] }); - return $contacts; -} - -=item admin_fetch_problem ID - -Return an array reference of data relating to a problem, to be used in the admin interface. -Uses any site_restriction defined by a cobrand. - -=cut - -sub admin_fetch_problem { - my ($id) = @_; - my $problem = dbh()->selectall_arrayref("select * from problem - where id=? - $site_restriction", { Slice=>{} }, $id); - return $problem; -} - -=item admin_fetch_update ID - -Return an array reference of data relating to an update, to be used in the admin interface. -Uses any site_restriction defined by a cobrand. - -=cut -sub admin_fetch_update { - my ($id) = @_; - my $update = dbh()->selectall_arrayref("select comment.*, problem.council from comment, problem - where comment.id=? - and problem.id = comment.problem_id - $site_restriction", { Slice=>{} }, $id); - return $update; -} - -=item timeline_problems - -Return a reference to an array of problems suitable for display in the admin timeline. -Uses any site_restriction defined by a cobrand. -=cut -sub timeline_problems { - my $current_timestamp = current_timestamp(); - my $problems = select_all("select state,id,name,email,title,council,category,service,cobrand,cobrand_data, - extract(epoch from created) as created, - extract(epoch from confirmed) as confirmed, - extract(epoch from whensent) as whensent - from problem where (created>=$current_timestamp-'7 days'::interval - or confirmed>=$current_timestamp-'7 days'::interval - or whensent>=$current_timestamp-'7 days'::interval) - $site_restriction"); - return $problems; - -} - -=item timeline_updates - -Return a reference to an array of updates suitable for display in the admin timeline. -Uses any site_restriction defined by a cobrand. - -=cut - -sub timeline_updates { - my $updates = select_all("select comment.*, - extract(epoch from comment.created) as created, - problem.council - from comment, problem - where comment.problem_id = problem.id - and comment.state='confirmed' - and comment.created>=" . current_timestamp() . "-'7 days'::interval - $site_restriction"); - return $updates; -} - -=item timeline_alerts COBRAND - -Return a reference to an array of alerts suitable for display in the admin timeline. Restricted to -cobranded alerts if a cobrand is specified. - -=cut -sub timeline_alerts { - my ($cobrand) = @_; - my $cobrand_clause = ''; - if ($cobrand) { - $cobrand_clause = " and cobrand = '$cobrand'"; - } - my $alerts = select_all("select *, - extract(epoch from whensubscribed) as whensubscribed - from alert where whensubscribed>=" . current_timestamp() . "-'7 days'::interval - and confirmed=1 - $cobrand_clause"); - return $alerts; - -} - -=item timeline_deleted_alerts COBRAND - -Return a reference to an array of deleted alerts suitable for display in the admin timeline. Restricted to -cobranded alerts if a cobrand is specified. - -=cut -sub timeline_deleted_alerts { - my ($cobrand) = @_; - my $cobrand_clause = ''; - if ($cobrand) { - $cobrand_clause = " and cobrand = '$cobrand'"; - } - - my $alerts = select_all("select *, - extract(epoch from whensubscribed) as whensubscribed, - extract(epoch from whendisabled) as whendisabled - from alert where whendisabled>=" . current_timestamp() . "-'7 days'::interval - $cobrand_clause"); - return $alerts; - -} - -=item timeline_questionnaires - -Return a reference to an array of questionnaires suitable for display in the admin timeline. Restricted to -questionnaires for cobranded problems if a cobrand is specified. - -=cut - -sub timeline_questionnaires { - my ($cobrand) = @_; - my $cobrand_clause = ''; - if ($cobrand) { - $cobrand_clause = " and cobrand = '$cobrand'"; - } - my $current_timestamp = current_timestamp(); - my $questionnaire = select_all("select questionnaire.*, - extract(epoch from questionnaire.whensent) as whensent, - extract(epoch from questionnaire.whenanswered) as whenanswered - from questionnaire, problem - where questionnaire.problem_id = problem.id - and (questionnaire.whensent>=$current_timestamp-'7 days'::interval - or questionnaire.whenanswered>=$current_timestamp-'7 days'::interval) - $cobrand_clause"); -} - -1; diff --git a/perllib/Standard.pm b/perllib/Standard.pm deleted file mode 100644 index 571065c14..000000000 --- a/perllib/Standard.pm +++ /dev/null @@ -1,42 +0,0 @@ -#!/usr/bin/perl -# -# Standard.pm: -# Common headers for Perl files. Mostly in the main namespace on purpose -# (Filter::Macro sadly didn't work, CPAN bug #20494) -# -# Copyright (c) 2007 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org; WWW: http://www.mysociety.org/ -# -# $Id: Standard.pm,v 1.3 2009-09-15 13:57:01 louise Exp $ - -use strict; -use warnings; -require 5.8.0; - -# Horrible boilerplate to set up appropriate library paths. -use FindBin; -use lib "$FindBin::Bin/../perllib"; -use lib "$FindBin::Bin/../commonlib/perllib"; - -use Page; - -package Standard; - -sub import { - my $package = shift; - my $db = shift; - unless ($db && $db eq '-db') { - use mySociety::Config; - use mySociety::DBHandle qw(dbh); - (my $file = __FILE__) =~ s{/[^/]*?$}{}; - mySociety::Config::set_file("$file/../conf/general"); - mySociety::DBHandle::configure( - Name => mySociety::Config::get('BCI_DB_NAME'), - User => mySociety::Config::get('BCI_DB_USER'), - Password => mySociety::Config::get('BCI_DB_PASS'), - Host => mySociety::Config::get('BCI_DB_HOST', undef), - Port => mySociety::Config::get('BCI_DB_PORT', undef) - ); - *main::dbh = \&dbh; - } -} diff --git a/perllib/Utils.pm b/perllib/Utils.pm index c16a02cd4..39c251876 100644 --- a/perllib/Utils.pm +++ b/perllib/Utils.pm @@ -12,6 +12,8 @@ package Utils; use strict; +use Encode; +use POSIX qw(strftime); use mySociety::DBHandle qw(dbh); use mySociety::GeoUtil; use mySociety::Locale; @@ -45,6 +47,7 @@ Takes the WGS84 latitude and longitude and returns OSGB36 easting and northing. sub convert_latlon_to_en { my ( $latitude, $longitude ) = @_; + local $SIG{__WARN__} = sub { die $_[0] }; my ( $easting, $northing ) = mySociety::Locale::in_gb_locale { mySociety::GeoUtil::wgs84_to_national_grid( $latitude, $longitude, 'G' ); @@ -136,4 +139,127 @@ sub london_categories { }; } +=head2 trim_text + + my $text = trim_text( $text_to_trim ); + +Strip leading and trailing white space from a string. Also reduces all +white space to a single space. + +Trim + +=cut + +sub trim_text { + my $input = shift; + for ($input) { + last unless $_; + s{\s+}{ }g; # all whitespace to single space + s{^ }{}; # trim leading + s{ $}{}; # trim trailing + } + return $input; +} + + +=head2 cleanup_text + +Tidy up text including removing contentious phrases, +SHOUTING and new lines and adding sentence casing. Takes an optional HASHREF +of args as follows. + +=over + +=item allow_multiline + +Do not flatten down to a single line if true. + +=back + +=cut + +sub cleanup_text { + my $input = shift || ''; + my $args = shift || {}; + + # lowercase everything if looks like it might be SHOUTING + $input = lc $input if $input !~ /[a-z]/; + + # clean up language and tradmarks + for ($input) { + + # shit -> poo + s{\bdog\s*shit\b}{dog poo}ig; + + # 'portakabin' to '[portable cabin]' (and variations) + s{\b(porta)\s*([ck]abin|loo)\b}{[$1ble $2]}ig; + s{kabin\]}{cabin\]}ig; + } + + # Remove unneeded whitespace + my @lines = grep { m/\S/ } split m/\n\n/, $input; + for (@lines) { + $_ = trim_text($_); + $_ = ucfirst $_; # start with capital + } + + my $join_char = $args->{allow_multiline} ? "\n\n" : " "; + $input = join $join_char, @lines; + + return $input; +} + +sub prettify_epoch { + my ( $s, $type ) = @_; + $type = 'short' if $type eq '1'; + + my @s = localtime($s); + my $tt = ''; + $tt = strftime('%H:%M', @s) unless $type eq 'date'; + my @t = localtime(); + if (strftime('%Y%m%d', @s) eq strftime('%Y%m%d', @t)) { + return "$tt " . _('today'); + } + $tt .= ', ' unless $type eq 'date'; + if (strftime('%Y %U', @s) eq strftime('%Y %U', @t)) { + $tt .= decode_utf8(strftime('%A', @s)); + } elsif ($type eq 'short') { + $tt .= decode_utf8(strftime('%e %b %Y', @s)); + } elsif (strftime('%Y', @s) eq strftime('%Y', @t)) { + $tt .= decode_utf8(strftime('%A %e %B %Y', @s)); + } else { + $tt .= decode_utf8(strftime('%a %e %B %Y', @s)); + } + return $tt; +} + +# argument is duration in seconds, rounds to the nearest minute +sub prettify_duration { + my ($s, $nearest) = @_; + if ($nearest eq 'week') { + $s = int(($s+60*60*24*3.5)/60/60/24/7)*60*60*24*7; + } elsif ($nearest eq 'day') { + $s = int(($s+60*60*12)/60/60/24)*60*60*24; + } elsif ($nearest eq 'hour') { + $s = int(($s+60*30)/60/60)*60*60; + } elsif ($nearest eq 'minute') { + $s = int(($s+30)/60)*60; + return _('less than a minute') if $s == 0; + } + my @out = (); + _part(\$s, 60*60*24*7, _('%d week'), _('%d weeks'), \@out); + _part(\$s, 60*60*24, _('%d day'), _('%d days'), \@out); + _part(\$s, 60*60, _('%d hour'), _('%d hours'), \@out); + _part(\$s, 60, _('%d minute'), _('%d minutes'), \@out); + return join(', ', @out); +} +sub _part { + my ($s, $m, $w1, $w2, $o) = @_; + if ($$s >= $m) { + my $i = int($$s / $m); + push @$o, sprintf(mySociety::Locale::nget($w1, $w2, $i), $i); + $$s -= $i * $m; + } +} + 1; |