diff options
Diffstat (limited to 'perllib/FixMyStreet')
28 files changed, 3886 insertions, 1 deletions
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..903a8b97e --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Report/New.pm @@ -0,0 +1,1188 @@ +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; + + next # TODO - move this to the cobrand + if $c->cobrand->moniker eq 'southampton' + && $contact->category eq 'Street lighting'; + + next if $contact->category eq _('Other'); + + push @category_options, $contact->category; + } + + 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..c8240948d --- /dev/null +++ b/perllib/FixMyStreet/App/View/Web.pm @@ -0,0 +1,91 @@ +package FixMyStreet::App::View::Web; +use base 'Catalyst::View::TT'; + +use strict; +use warnings; + +use mySociety::Locale; +use FixMyStreet; +use CrossSell; + +__PACKAGE__->config( + TEMPLATE_EXTENSION => '.html', + INCLUDE_PATH => [ # + FixMyStreet->path_to( 'templates', 'web', 'default' ), + ], + ENCODING => 'utf8', + render_die => 1, + expose_methods => [ 'loc', 'nget', 'tprintf', 'display_crossell_advert' ], +); + +=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(); + + # fake up the old style $q + my $q = { site => $c->cobrand->moniker, }; + $q->{site} = 'fixmystreet' if $q->{site} eq 'default'; + + return CrossSell::display_advert( $q, $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; |