diff options
Diffstat (limited to 'perllib')
33 files changed, 4508 insertions, 245 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..7ffc77f1f --- /dev/null +++ b/perllib/Catalyst/Plugin/Session/State/Cookie.pm @@ -0,0 +1,357 @@ +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}; + } + 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/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/App.pm b/perllib/FixMyStreet/App.pm new file mode 100644 index 000000000..2ae90c2fa --- /dev/null +++ b/perllib/FixMyStreet/App.pm @@ -0,0 +1,301 @@ +package FixMyStreet::App; +use Moose; +use namespace::autoclean; + +use Catalyst::Runtime 5.80; +use FixMyStreet; +use FixMyStreet::Cobrand; +use Memcached; +use Problems; +use mySociety::Email; +use FixMyStreet::Map; + +use Catalyst ( + 'Static::Simple', # + 'Unicode', + 'Session', + 'Session::Store::DBIC', + 'Session::State::Cookie', # FIXME - we're using our own override atm + 'Authentication', +); + +extends 'Catalyst'; + +our $VERSION = '0.01'; + +__PACKAGE__->config( + + # get the config from the core object + %{ FixMyStreet->config() }, + + name => 'FixMyStreet::App', + + # 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 * 6, # 6 months + }, + + 'Plugin::Authentication' => { + default_realm => 'default', + default => { + credential => { # Catalyst::Authentication::Credential::Password + class => 'Password', + password_field => 'password', + password_type => 'hashed', + password_hash_type => 'SHA-1', + }, + 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 debaug 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); + + return $cobrand_class->new( { request => $c->req } ); +} + +=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 ); + + Problems::set_site_restriction_with_cobrand_object($cobrand); + + Memcached::set_namespace( FixMyStreet->config('BCI_DB_NAME') . ":" ); + + FixMyStreet::Map::set_map_class( $c->request->param('map') ); + + return $cobrand; +} + +=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 || {}; + + # create the vars to pass to the email template + my $vars = { + from => FixMyStreet->config('CONTACT_EMAIL'), + %{ $c->stash }, + %$extra_stash_values, + additional_template_paths => + [ $c->cobrand->path_to_email_templates->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::Email::construct_email( + { + _unwrapped_body_ => $email->body, # will get line wrapped + $email->header_pairs + } + ); + + # send the email + $c->model('EmailSend')->send($email_text); + + return $email; +} + +=head1 SEE ALSO + +L<FixMyStreet::App::Controller::Root>, L<Catalyst> + +=cut + +1; diff --git a/perllib/FixMyStreet/App/Controller/About.pm b/perllib/FixMyStreet/App/Controller/About.pm new file mode 100644 index 000000000..b444e02bb --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/About.pm @@ -0,0 +1,33 @@ +package FixMyStreet::App::Controller::About; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::About - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + +=head2 about + +Show the 'about us' page. + +=cut + +sub about : Path : Args(0) { + my ( $self, $c ) = @_; + + # don't need to do anything here - should just pass through. +} + +__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..7526c2c25 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Auth.pm @@ -0,0 +1,240 @@ +package FixMyStreet::App::Controller::Auth; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use Email::Valid; +use Net::Domain::TLD; +use mySociety::AuthToken; +use Digest::SHA1 qw(sha1_hex); + +=head1 NAME + +FixMyStreet::App::Controller::Auth - Catalyst Controller + +=head1 DESCRIPTION + +Controller for all the authentication related pages - create account, login, +logout. + +=head1 METHODS + +=head2 index + +Present the user with a login / create account page. + +=cut + +sub general : Path : Args(0) { + my ( $self, $c ) = @_; + my $req = $c->req; + + # all done unless we have a form posted to us + return unless $req->method eq 'POST'; + + # decide which action to take + $c->detach('email_login') if $req->param('email_login'); + $c->detach('login'); # default + +} + +=head2 login + +Allow the user to legin with a username and a password. + +=cut + +sub login : Private { + my ( $self, $c ) = @_; + + my $email = $c->req->param('email') || ''; + my $password = $c->req->param('password') || ''; + my $remember_me = $c->req->param('remember_me') || 0; + + # logout 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; + + $c->res->redirect( $c->uri_for('/my') ); + return; + } + + # could not authenticate - show an error + $c->stash->{login_error} = 1; +} + +=head2 email_login + +Email the user the details they need to log 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_login : 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 $token_obj = $c->model('DB::Token') # + ->create( + { + scope => 'email_login', + data => { email => $good_email } + } + ); + + # log the user in, send them an email and redirect to the welcome page + $c->stash->{token} = $token_obj->token; + $c->send_email( 'login.txt', { to => $good_email } ); + $c->res->redirect( $c->uri_for('token') ); +} + +=head2 token + +Handle the 'email_login' tokens. Find the account for the email address +(creating if needed), authenticate the user and delete the token. + +=cut + +sub token : Local { + my ( $self, $c, $url_token ) = @_; + + # check for a token - if none found then return + return unless $url_token; + + # retrieve the token or return + my $token_obj = + $c->model('DB::Token') + ->find( { scope => 'email_login', token => $url_token, } ); + + if ( !$token_obj ) { + $c->stash->{token_not_found} = 1; + return; + } + + # logout in case we are another user + $c->logout(); + + # get the email and scrap the token + my $email = $token_obj->data->{email}; + $token_obj->delete; + + # find or create the user related to the token and delete the token + my $user = $c->model('DB::User')->find_or_create( { email => $email } ); + $c->authenticate( { email => $user->email }, 'no_password' ); + + # send the user to their page + $c->res->redirect( $c->uri_for('/my') ); +} + +=head2 change_password + +Let the user change their password. + +=cut + +sub change_password : Local { + my ( $self, $c ) = @_; + + # FIXME - handle not being logged in more elegantly + unless ( $c->user ) { + $c->res->redirect( $c->uri_for('/auth') ); + $c->detach; + } + + # 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 => sha1_hex($new) } ); + $c->stash->{password_changed} = 1; + +} + +=head2 logout + +Log the user out. Tell them we've done so. + +=cut + +sub logout : 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/FAQ.pm b/perllib/FixMyStreet/App/Controller/FAQ.pm new file mode 100644 index 000000000..6b8fb1191 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/FAQ.pm @@ -0,0 +1,35 @@ +package FixMyStreet::App::Controller::FAQ; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::FAQ - Catalyst Controller + +=head1 DESCRIPTION + +Show the FAQ page - does some smarts to choose the correct template depending on +language. + +=cut + +sub faq : Path : 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; +} + +__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..1189fe901 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/My.pm @@ -0,0 +1,36 @@ +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 ) = @_; + + # FIXME - handle not being logged in more elegantly + unless ( $c->user ) { + $c->res->redirect( $c->uri_for('/auth') ); + $c->detach; + } + +} + +__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..071b36df0 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Report/New.pm @@ -0,0 +1,1181 @@ +package FixMyStreet::App::Controller::Report::New; + +use Moose; +use namespace::autoclean; +BEGIN { extends 'Catalyst::Controller'; } + +use FixMyStreet::Geocode; +use Encode; +use Sort::Key qw(keysort); +use List::MoreUtils qw(uniq); +use HTML::Entities; +use mySociety::MaPit; +use Path::Class; +use Utils; +use mySociety::EmailUtil; + +=head1 NAME + +FixMyStreet::App::Controller::Report::New + +=head1 DESCRIPTION + +Create a new report, or complete a partial one . + +=head1 PARAMETERS + +=head2 flow control + +submit_map: true if we reached this page by clicking on the map + +submit_problem: true if a problem has been submitted + +=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 + +=head2 can be ignored + +all_pins: related to map display - not relevant to creation of a new report + +=cut + +sub report_new : Path : Args(0) { + my ( $self, $c ) = @_; + + # set up the page + $c->forward('setup_page'); + + # create the report - loading a partial if available + $c->forward('initialize_report'); + + # work out the location for this report and do some checks + return + unless $c->forward('determine_location') + && $c->forward('load_councils'); + + # 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('process_user') + && $c->forward('process_report') + && $c->forward('process_photo') + && $c->forward('check_form_submitted') + && $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'); + + # use strict; + # use Standard; + # use mySociety::AuthToken; + # use mySociety::Config; + # use mySociety::EvEl; + # use mySociety::Locale; + + 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->config->{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 => '', + + } + ); + + # 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); + } + + # 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( '/L', $token->token ); + + my $sender = mySociety::Config::get('CONTACT_EMAIL'); + $sender =~ s/team/fms-DO-NOT-REPLY/; + + # TODO - used to be sent using EvEl + $c->send_email( + 'partial.txt', + { + to => $report->user->email, + from => $sender + } + ); + + $c->res->body('SUCCESS'); + return 1; +} + +=head2 setup_page + +Setup the page - notably add the map js to the stash + +=cut + +sub setup_page : Private { + my ( $self, $c ) = @_; + + $c->stash->{extra_js_verbatim} = FixMyStreet::Map::header_js(); + + 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 via mobile apps or by +specially tagging photos on Flickr. 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->model("DB::Problem") # + ->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; + } + } + } + else { + + # 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 ); + } + + } + + $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 a user search query C<pc>. Returns false if no location could be +found. + +=cut + +sub determine_location : Private { + my ( $self, $c ) = @_; + + return + unless $c->forward('determine_location_from_tile_click') + || $c->forward('determine_location_from_coords') + || $c->forward('determine_location_from_pc') + || $c->forward('determine_location_from_report'); + + # These should be set now + my $lat = $c->stash->{latitude}; + my $lon = $c->stash->{longitude}; + + # Check this location is okay to be displayed for the cobrand + my ( $success, $error_msg ) = $c->cobrand->council_check( # + { lat => $lat, lon => $lon }, + 'submit_problem' + ); + + # If in UK and we have a lat,lon coocdinate check it is in UK + if ( !$error_msg && $lat && $c->config->{COUNTRY} eq 'GB' ) { + eval { Utils::convert_latlon_to_en( $lat, $lon ); }; + $error_msg = + _( "We had a problem with the supplied co-ordinates - outside the UK?" + ) if $@; + } + + # all good + return 1 if !$error_msg; + + # show error + $c->stash->{pc_error} = $error_msg; + 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->req, # + $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_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'); + my $longitude = $c->req->param('longitude'); + + 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 1; + } + + 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 ) = @_; + + # check for something to search + my $pc = $c->req->param('pc') || return; + $c->stash->{pc} = $pc; # for template + + my ( $latitude, $longitude, $error ) = + eval { FixMyStreet::Geocode::lookup( $pc, $c->req ) }; + + # Check that nothing blew up + if ($@) { + warn "Error: $@"; + return; + } + + # 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 1; + } + + # $error doubles up to return multiple choices by being an array + if ( ref($error) eq 'ARRAY' ) { + @$error = map { decode_utf8($_) } @$error; + $c->stash->{possible_location_matches} = $error; + return; + } + + # pass errors back to the template + $c->stash->{pc_error} = $error; + return; +} + +=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 load_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_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 = $c->cobrand->area_types(); + + # TODO: I think we want in_gb_locale around the next line, needs testing + my $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 }, + 'submit_problem' ); + if ( !$success ) { + $c->stash->{location_error} = $error_msg; + return; + } + + # If we don't have any councils we can't accept the report + if ( !scalar keys %$all_councils ) { + $c->stash->{location_error} = + _( 'That spot does not appear to be covered by a council. If you' + . ' have tried to report an issue past the shoreline, for' + . ' example, please specify the closest point on land.' ); + return; + } + + # edit hash in-place + _remove_redundant_councils($all_councils); + + # 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; +} + +# TODO - should not be here. +# These are country specific tweaks that should be in the cobrands +sub _remove_redundant_councils { + my $all_councils = shift; + + # UK specific tweaks + if ( FixMyStreet->config('COUNTRY') eq 'GB' ) { + + # 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}; + } + + # Norway specific tweaks + if ( FixMyStreet->config('COUNTRY') eq 'NO' ) { + + # Oslo is both a kommune and a fylke, we only want to show it once + delete $all_councils->{301} # + if $all_councils->{3}; + } + +} + +=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_council_ids = keys %{ $c->stash->{all_councils} }; + + my @contacts # + = $c # + ->model('DB::Contact') # + ->not_deleted # + ->search( { area_id => \@all_council_ids } ) # + ->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) { + push @area_ids_to_list, $_->area_id; + } + + # 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:'); + } + else { + + @contacts = keysort { $_->category } @contacts; + foreach my $contact (@contacts) { + push @area_ids_to_list, $contact->area_id; + push @category_options, $contact->category + unless $contact->category eq _('Other'); + } + + 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} = \@area_ids_to_list; + $c->stash->{category_label} = $category_label; + $c->stash->{category_options} = \@category_options; + + # add some conveniant things to the stash + my $all_councils = $c->stash->{all_councils}; + my %area_ids_to_list_hash = map { $_ => 1 } @area_ids_to_list; + + my @missing_details_councils = + grep { !$area_ids_to_list_hash{$_} } # + 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 ) = @_; + + # FIXME - If user already logged in use them regardless + + # Extract all the params to a hash to make them easier to work with + my %params = # + map { $_ => scalar $c->req->param($_) } # + ( 'email', 'name', 'phone', ); + + # cleanup the email address + my $email = lc $params{email}; + $email =~ s{\s+}{}g; + + my $report = $c->stash->{report}; + my $report_user # + = ( $report ? $report->user : undef ) + || $c->model('DB::User')->find_or_new( { email => $email } ); + + # set the user's name and phone (if given) + $report_user->name( _trim_text( $params{name} ) ); + $report_user->phone( _trim_text( $params{phone} ) ) if $params{phone}; + + $c->stash->{report_user} = $report_user; + + 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 + +# args: allow_multiline => bool - strips out "\n\n" linebreaks +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 _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; +} + +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', # + 'name', 'may_show_name', # + 'category', # + 'partial', 'skipped', 'submit_problem' # + ); + + # 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} ); + + # Short circuit unless the form has been submitted + return 1 unless $params{submit_problem}; + + # set some simple bool values (note they get inverted) + $report->anonymous( $params{may_show_name} ? 0 : 1 ); + $report->used_map( $params{skipped} ? 0 : 1 ); + + # clean up text before setting + $report->title( _cleanup_text( $params{title} ) ); + $report->detail( + _cleanup_text( $params{detail}, { allow_multiline => 1 } ) ); + + # set these straight from the params + $report->name( _trim_text( $params{name} ) ); + $report->category( _ $params{category} ); + + my $mapit_query = + sprintf( "4326/%s,%s", $report->longitude, $report->latitude ); + my $areas = mySociety::MaPit::call( 'point', $mapit_query ); + $report->areas( ',' . join( ',', sort keys %$areas ) . ',' ); + + # determine the area_types that this cobrand is interested in + my @area_types = $c->cobrand->area_types(); + my %area_types_lookup = map { $_ => 1 } @area_types; + + # get all the councils that are of these types and cover this area + my %councils = + map { $_ => 1 } # + grep { $area_types_lookup{ $areas->{$_}->{type} } } # + keys %$areas; + + # partition the councils onto these two arrays + my @councils_with_category = (); + my @councils_without_category = (); + + # all councils have all categories for emptyhomes + if ( $c->cobrand->moniker eq 'emptyhomes' ) { + @councils_with_category = keys %councils; + } + else { + + my @contacts = $c-> # + model('DB::Contact') # + ->not_deleted # + ->search( + { + area_id => [ keys %councils ], # + category => $report->category + } + )->all; + + # clear category if it is not in db for possible councils + $report->category(undef) unless @contacts; + + my %councils_with_contact_for_category = + map { $_->area_id => 1 } @contacts; + + foreach my $council_key ( keys %councils ) { + $councils_with_contact_for_category{$council_key} + ? push( @councils_with_category, $council_key ) + : push( @councils_without_category, $council_key ); + } + + } + + # construct the council string: + # 'x,x' - x are councils_ids that have this category + # 'x,x|y,y' - x are councils_ids that have this category, y don't + my $council_string = join '|', grep { $_ } # + ( + join( ',', @councils_with_category ), + join( ',', @councils_without_category ) + ); + $report->council($council_string); + + # 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 { Page::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 + my %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_user = $c->stash->{report_user}; + 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. Throw away changes to + # the name and phone. TODO - propagate changes using tokens. + $report_user->discard_changes(); + } + + # add the user to the report + $report->user($report_user); + + # 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; + + # 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 + +# FIXME - much of this should not happen here or in maps code but in the +# templates. 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}; + + # Forms that allow photos need a different enctype + my $allow_photo_upload = $c->cobrand->allow_photo_upload; + + # Don't do anything if the user skipped the map + if ( $c->req->param('skipped') ) { + + my $enctype = + $allow_photo_upload + ? ' enctype="multipart/form-data"' + : ''; + + my $cobrand_form_elements = + $c->cobrand->form_elements('mapSkippedForm'); + + my $form_action = $c->uri_for(''); + my $pc = encode_entities( $c->stash->{pc} ); + + $c->stash->{map_html} = <<"END_MAP_HTML"; +<form action="$form_action" method="post" name="mapSkippedForm"$enctype> +<input type="hidden" name="latitude" value="$latitude"> +<input type="hidden" name="longitude" value="$longitude"> +<input type="hidden" name="pc" value="$pc"> +<input type="hidden" name="skipped" value="1"> +$cobrand_form_elements +<div id="skipped-map"> +END_MAP_HTML + + } + else { + my $map_type = $allow_photo_upload ? 2 : 1; + + $c->stash->{map_html} = FixMyStreet::Map::display_map( + $c->req, + latitude => $latitude, + longitude => $longitude, + type => $map_type, + pins => [ [ $latitude, $longitude, 'purple' ] ], + ); + } + + # get the closing for the map + $c->stash->{map_end} = FixMyStreet::Map::display_map_end(1); + + 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 straigh there. + if ( $report->confirmed ) { + 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 $token = + $c->model("DB::Token") + ->create( { scope => 'problem', data => $report->id } ); + $c->stash->{token_url} = $c->uri_for( '/P', $token->token ); + $c->send_email( 'problem-confirm.txt', { to => $report->user->email } ); + + # tell user that they've been sent an email + $c->stash->{template} = 'email_sent.html'; + $c->stash->{email_type} = 'problem'; +} + +__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..2a25d4040 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Root.pm @@ -0,0 +1,80 @@ +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 + +=cut + +sub index : Path : Args(0) { + my ( $self, $c ) = @_; + $c->res->body('index'); +} + +=head2 default + +Forward to the standard 404 error page + +=cut + +sub default : Path { + my ( $self, $c ) = @_; + $c->detach('/page_not_found'); +} + +=head2 page_not_found + + $c->detach('/page_not_found'); + +Display a 404 page. + +=cut + +sub page_not_found : Private { + my ( $self, $c ) = @_; + + $c->stash->{template} = 'errors/page_not_found.html'; + $c->response->status(404); +} + +=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/Tokens.pm b/perllib/FixMyStreet/App/Controller/Tokens.pm new file mode 100644 index 000000000..1d64d9e18 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Tokens.pm @@ -0,0 +1,129 @@ +package FixMyStreet::App::Controller::Tokens; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use FixMyStreet::Alert; + +=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 $problem_id = $auth_token->data; + my $problem = $c->model('DB::Problem')->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 + my $alert_id = + FixMyStreet::Alert::create( $problem->user->email, 'new_updates', + $problem->cobrand, $problem->cobrand_data, $problem_id ); + FixMyStreet::Alert::confirm($alert_id); + + # log the problem creation user in to the site + $c->authenticate( { email => $problem->user->email }, 'no_password' ); + + return 1; +} + +=head2 redirect_to_partial_problem + + /P/... + +Redirect user to continue filling in a partial problem. + +=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 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} = '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..75ca4dd81 --- /dev/null +++ b/perllib/FixMyStreet/App/View/Web.pm @@ -0,0 +1,85 @@ +package FixMyStreet::App::View::Web; +use base 'Catalyst::View::TT'; + +use strict; +use warnings; + +use mySociety::Locale; +use FixMyStreet; + +__PACKAGE__->config( + TEMPLATE_EXTENSION => '.html', + INCLUDE_PATH => [ # + FixMyStreet->path_to( 'templates', 'web', 'default' ), + ], + ENCODING => 'utf8', + render_die => 1, + expose_methods => [ 'loc', 'nget', 'tprintf', ], +); + +=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_crossell_advert + + [% display_crossell_advert( email, name ) %] + +Displays a crosssell advert if permitted by the cobrand. + +=cut + +sub display_crossell_advert { + my ( $self, $c, $email, $name ) = @_; + + return unless $c->cobrand->allow_crosssell_adverts(); + return CrossSell::display_advert( $c->req, $email, $name ); +} + +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..4d20d6522 --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/Barnet.pm @@ -0,0 +1,81 @@ +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' ); +} + +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 $q = $self->request; + + 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( $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; +} + +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 ); +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand/Default.pm b/perllib/FixMyStreet/Cobrand/Default.pm new file mode 100644 index 000000000..9054af81c --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/Default.pm @@ -0,0 +1,551 @@ +package FixMyStreet::Cobrand::Default; + +use strict; +use warnings; +use FixMyStreet; +use URI; + +use Carp; + +=head2 new + + my $cobrand = $class->new; + my $cobrand = $class->new( { request => $c->req } ); + +Create a new cobrand object, optionally setting the web request. + +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+)$}; + return lc($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 'default'; +} + +=head2 q + + $request = $cobrand->q; + +Often the cobrand needs access to the request so we add it at the start by +passing it to ->new. If the request has not been set and you call this (or a +method that needs it) then it croaks. This is probably because you are trying to +use a request-related method out of a request-context. + +=cut + +sub q { + my $self = shift; + return $self->{request} + || croak "No request has been set" + . " - should you be calling this method outside of a web request?"; +} + +=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 ); +} + +=head2 path_to_email_templates + + $path = $cobrand->path_to_email_templates( ); + +Returns the path to the templates for this cobrand - by default +"templates/email/$moniker" + +=cut + +sub path_to_email_templates { + my $self = shift; + return FixMyStreet->path_to( 'templates/email', $self->moniker ); +} + +=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 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 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|nb,Norwegian,nb_NO', $lang ); # XXX Testing + 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 Problems::recent_photos(@_); +} + +=head2 recent + +Return recent problems on the site. + +=cut + +sub recent { + my $self = shift; + return Problems::recent(@_); +} + +=head2 front_stats + +Given a QUERY, return a block of html for showing front stats for the site + +=cut + +sub front_stats { + my $self = shift; + return Problems::front_stats(@_); +} + +=head2 disambiguate_location + +Given a STRING ($_[1]) representing a location and a QUERY, return a string that +includes any disambiguating information available + +=cut + +sub disambiguate_location { "$_[1]&gl=uk" } + +=head2 prettify_epoch + +Parameter is EPOCHTIME + +=cut + +sub prettify_epoch { 0 } + +=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_params + +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. + +=cut + +sub extra_params { '' } + +=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 url + +Given a URL ($_[1]), QUERY, EXTRA_DATA, return a URL with any extra params +needed appended to it. + +=cut + +sub url { $_[1] } + +=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.com' } + +=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 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 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 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 { + my $self = shift; + my $cobrand_moniker_uc = uc( $self->moniker ); + + my $email_vhost = + mySociety::Config::get("EMAIL_VHOST_$cobrand_moniker_uc") + || mySociety::Config::get("EMAIL_VHOST") + || ''; + + return $email_vhost + && "http://$email_vhost" eq mySociety::Config::get("BASE_URL"); +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand/EmptyHomes.pm b/perllib/FixMyStreet/Cobrand/EmptyHomes.pm new file mode 100644 index 000000000..5ebee0d2b --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/EmptyHomes.pm @@ -0,0 +1,72 @@ +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 +} + +=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'; +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand/FiksGataMi.pm b/perllib/FixMyStreet/Cobrand/FiksGataMi.pm new file mode 100644 index 000000000..43565d8ea --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/FiksGataMi.pm @@ -0,0 +1,38 @@ +package FixMyStreet::Cobrand::FiksGataMi; +use base 'FixMyStreet::Cobrand::Default'; + +use strict; +use warnings; + +use Carp; + +sub set_lang_and_domain { + my ( $self, $lang, $unicode, $dir ) = @_; + mySociety::Locale::negotiate_language( + 'en-gb,English,en_GB|nb,Norwegian,nb_NO', 'nb' ); + mySociety::Locale::gettext_domain( 'FixMyStreet', $unicode, $dir ); + mySociety::Locale::change(); +} + +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 area_types { + return ( 'NKO', 'NFY' ); +} + +sub area_min_generation { + return ''; +} + +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..55b22d433 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Abuse.pm @@ -0,0 +1,19 @@ +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"); +__PACKAGE__->table("abuse"); +__PACKAGE__->add_columns( "email", { data_type => "text", is_nullable => 0 } ); + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-03-28 12:14:16 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:fCIpGt51z5iDH9LmHeuRYQ + +# 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/Contact.pm b/perllib/FixMyStreet/DB/Result/Contact.pm new file mode 100644 index 000000000..5a993a773 --- /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"); +__PACKAGE__->table("contacts"); +__PACKAGE__->add_columns( + "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 }, + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "contacts_id_seq", + }, +); +__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-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:u6kRlRfgwAiCqmGhj6io5A + +1; diff --git a/perllib/FixMyStreet/DB/Result/Problem.pm b/perllib/FixMyStreet/DB/Result/Problem.pm new file mode 100644 index 000000000..bafad4ec0 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Problem.pm @@ -0,0 +1,190 @@ +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"); +__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 }, + "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 }, + "name", + { data_type => "text", is_nullable => 0 }, + "anonymous", + { data_type => "boolean", is_nullable => 0 }, + "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 }, + "latitude", + { data_type => "double precision", is_nullable => 0 }, + "longitude", + { data_type => "double precision", is_nullable => 0 }, + "user_id", + { data_type => "integer", is_foreign_key => 1, 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" }, +); + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:+a9n7IKg3yFdgxNIbo3SGg + +=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 !~ 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 is_from_abuser + + $bool = $problem->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; +} + +=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; +} + +1; diff --git a/perllib/FixMyStreet/DB/Result/Session.pm b/perllib/FixMyStreet/DB/Result/Session.pm new file mode 100644 index 000000000..a50c3780b --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Session.pm @@ -0,0 +1,24 @@ +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"); +__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-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:E6SUYbAPJMQSXTrvn0x3kg + +# 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..e4ea7262a --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Token.pm @@ -0,0 +1,86 @@ +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"); +__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-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:tClh4Spd63IpCeiGVHfrEQ + +# 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..32361ca48 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/User.pm @@ -0,0 +1,84 @@ +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"); +__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( + "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-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:36KVfhjrygEEmpmWm/vZBg + +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 !~ 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->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; +} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/Contact.pm b/perllib/FixMyStreet/DB/ResultSet/Contact.pm new file mode 100644 index 000000000..52ff498a6 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/Contact.pm @@ -0,0 +1,20 @@ +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 } ); +} + +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/Map.pm b/perllib/FixMyStreet/Map.pm index 5305b360a..62dab454b 100644 --- a/perllib/FixMyStreet/Map.pm +++ b/perllib/FixMyStreet/Map.pm @@ -77,7 +77,7 @@ sub header { my $cobrand = Page::get_cobrand($q); my $cobrand_form_elements = Cobrand::form_elements( $cobrand, 'mapForm', $q ); - my $form_action = Cobrand::url( $cobrand, '/', $q ); + my $form_action = Cobrand::url( $cobrand, '/report/new', $q ); my $encoding = ''; $encoding = ' enctype="multipart/form-data"' if $type == 2; my $pc = ent($q->param('pc') || ''); diff --git a/perllib/FixMyStreet/TestMech.pm b/perllib/FixMyStreet/TestMech.pm new file mode 100644 index 000000000..c16f288c8 --- /dev/null +++ b/perllib/FixMyStreet/TestMech.pm @@ -0,0 +1,307 @@ +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 Digest::SHA1 'sha1_hex'; + +=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 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 = + FixMyStreet::App->model('DB::User') + ->find_or_create( { email => $email } ); + ok $user, "found/created user for $email"; + + # store the old password and then change it + my $old_password_sha1 = $user->password; + $user->update( { password => sha1_hex('secret') } ); + + # log in + $mech->get_ok('/auth'); + $mech->submit_form_ok( + { with_fields => { email => $email, password => 'secret' } }, + "login using form" ); + $mech->logged_in_ok; + + # restore the password (if there was one) + $user->update( { password => $old_password_sha1 } ) if $old_password_sha1; + + 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/logout'); + $mech->not_logged_in_ok; +} + +sub delete_user { + my $mech = shift; + my $user = shift; + + $mech->log_out_ok; + ok( $_->delete, "delete problem " . $_->title ) # + for $user->problems; + 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 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 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 @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; + + my $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 eq 'not found'; + + return $expires || 0; +} + +1; diff --git a/perllib/Page.pm b/perllib/Page.pm index 24c52885a..391926b4f 100644 --- a/perllib/Page.pm +++ b/perllib/Page.pm @@ -25,6 +25,7 @@ use IO::String; use POSIX qw(strftime); use URI::Escape; use Text::Template; +use Template; use Memcached; use Problems; @@ -267,117 +268,144 @@ sub template_include { return $template->fill_in(HASH => \%params); } +=item tt2_template_include + + $html = tt2_template_include( 'header', $q, $vars ); + +Return HTML for a template, given a template name, request, and +any parameters needed. This uses the TT2 templates that the Catalyst port uses. +Intended to prevent having duplicate headers and footers whilst the migration is +in progress. + +=cut + +sub _tt2_template_include_path { + my $q = shift; + + # work out where the emplate dir is relative to the current file + ( my $project_dir = __FILE__ ) =~ s{/[^/]*?$}{}; + my $template_root = "$project_dir/../templates/web"; + + # tidy up the '/foo/..' cruft + 1 while $template_root =~ s{[^/]+/../}{}; + + my @paths = (); + push @paths, "$template_root/$q->{site}" if $q->{site}; # cobrand + push @paths, "$template_root/default"; # fallback + + # warn "template path: $_" for @paths; + + return \@paths; +} + +sub tt2_template_include { + my ( $template, $q, $params ) = @_; + + # check that the template is 'header.html' or 'footer.html' - this is for + # transition only + unless ( $template eq 'header.html' || $template eq 'footer.html' ) { + warn "template not '(header|footer).html': '$template'"; + return undef; + } + + # create the template object + my $tt2 = Template->new( + { + INCLUDE_PATH => _tt2_template_include_path($q), + ENCODING => 'utf8', + } + ); + + # add/edit bits on the params to suit new templates + $params->{loc} = sub { return _(@_) }; # create the loc function for i18n + $params->{legacy_title} = + ( $params->{title} || '' ) . ( $params->{site_title} || '' ); + $params->{legacy_rss} = delete $params->{rss}; + + # fake parts of the config that the templates need + $params->{c}{config}{STAGING_SITE} = mySociety::Config::get('STAGING_SITE'); + $params->{c}{req}{uri}{path} = $ENV{REQUEST_URI}; + + + my $html = ''; + $tt2->process( $template, $params, \$html ); + + return $html; +} + =item header Q [PARAM VALUE ...] -Return HTML for the top of the page, given PARAMs (TITLE is required). + $html = Page::header( $q, %params ); + +Return HTML for the top of the page, given %params ('title' is required). + +Also prints the HTTP headers for the page to STDOUT. =cut + sub header ($%) { - my ($q, %params) = @_; - my $context = $params{context}; - my $default_params = Cobrand::header_params(get_cobrand($q), $q, %params); + my ( $q, %params ) = @_; + + # get the context + my $context = $params{context}; + + # get default header parameters for the cobrand + 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{$_})); + %params = ( %default_params, %params ); + + # check that all the params given ar allowed + my %permitted_params = map { $_ => 1 } ( + 'title', 'rss', 'expires', 'lastmodified', + 'template', 'cachecontrol', 'context', 'status_code', + 'robots', 'js', + ); + foreach ( keys %params ) { + croak "bad parameter '$_'" if ( !exists( $permitted_params{$_} ) ); } + # create the HTTP header my %head = (); - $head{-expires} = $params{expires} if $params{expires}; - $head{'-last-modified'} = time2str($params{lastmodified}) if $params{lastmodified}; + $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}; + $head{'-Cache-Control'} = $params{cachecontrol} if $params{cachecontrol}; + $head{'-status'} = $params{status_code} if $params{status_code}; print $q->header(%head); + + # mangle the title $params{title} ||= ''; $params{title} .= ' - ' if $params{title}; - $params{title} = ent($params{title}); - $params{lang} = $mySociety::Locale::lang; + $params{title} = ent( $params{title} ); + + # get the language + $params{lang} = $mySociety::Locale::lang; - my $vars = template_vars($q, %params); - my $html = template_include('header', $q, template_root($q), %$vars); + # produce the html + my $vars = template_vars( $q, %params ); + my $html = tt2_template_include( 'header.html', $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 ( $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, pc => $pc, ); - %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 - } + my $html = tt2_template_include( 'footer.html', $q, \%params ); - 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 + return $html; } =item error_page Q MESSAGE diff --git a/perllib/Problems.pm b/perllib/Problems.pm index 3710c3a95..111583fd5 100644 --- a/perllib/Problems.pm +++ b/perllib/Problems.pm @@ -35,6 +35,16 @@ sub set_site_restriction { } } +# Set the site restrictions using the new cobrand style - no need to special +# case 'fixmystreet' as default cobrand takes care of that. +sub set_site_restriction_with_cobrand_object { + my $cobrand = shift; + + my $cobrand_data = $cobrand->extra_data; + ( $site_restriction, $site_key ) = + $cobrand->site_restriction($cobrand_data); +} + sub current_timestamp { my $current_timestamp = dbh()->selectrow_array('select ms_current_timestamp()'); return "'$current_timestamp'::timestamp"; |