package Travelynx; use Mojo::Base 'Mojolicious'; use Mojo::Pg; use Mojo::Promise; use Mojolicious::Plugin::Authentication; use Cache::File; use Crypt::Eksblowfish::Bcrypt qw(bcrypt en_base64); use DateTime; use DateTime::Format::Strptime; use Encode qw(decode encode); use File::Slurp qw(read_file); use Geo::Distance; use JSON; use List::Util; use List::UtilsBy qw(uniq_by); use List::MoreUtils qw(after_incl before_incl first_index); use Travel::Status::DE::DBWagenreihung; use Travel::Status::DE::IRIS; use Travel::Status::DE::IRIS::Stations; use Travelynx::Helper::Sendmail; use XML::LibXML; sub check_password { my ( $password, $hash ) = @_; if ( bcrypt( $password, $hash ) eq $hash ) { return 1; } return 0; } sub epoch_to_dt { my ($epoch) = @_; # Bugs (and user errors) may lead to undefined timestamps. Set them to # 1970-01-01 to avoid crashing and show obviously wrong data instead. $epoch //= 0; return DateTime->from_epoch( epoch => $epoch, time_zone => 'Europe/Berlin', locale => 'de-DE', ); } sub get_station { my ( $station_name, $exact_match ) = @_; my @candidates = Travel::Status::DE::IRIS::Stations::get_station($station_name); if ( @candidates == 1 ) { if ( not $exact_match ) { return $candidates[0]; } if ( $candidates[0][0] eq $station_name or $candidates[0][1] eq $station_name or $candidates[0][2] eq $station_name ) { return $candidates[0]; } return undef; } return undef; } sub startup { my ($self) = @_; push( @{ $self->commands->namespaces }, 'Travelynx::Command' ); $self->defaults( layout => 'default' ); $self->types->type( json => 'application/json; charset=utf-8' ); $self->plugin('Config'); if ( $self->config->{secrets} ) { $self->secrets( $self->config->{secrets} ); } chomp $self->app->config->{version}; $self->plugin( authentication => { autoload_user => 1, fail_render => { template => 'login' }, load_user => sub { my ( $self, $uid ) = @_; return $self->get_user_data($uid); }, validate_user => sub { my ( $self, $username, $password, $extradata ) = @_; my $user_info = $self->get_user_password($username); if ( not $user_info ) { return undef; } if ( $user_info->{status} != 1 ) { return undef; } if ( check_password( $password, $user_info->{password_hash} ) ) { return $user_info->{id}; } return undef; }, } ); $self->sessions->default_expiration( 60 * 60 * 24 * 180 ); # Starting with v8.11, Mojolicious sends SameSite=Lax Cookies by default. # In theory, "The default lax value provides a reasonable balance between # security and usability for websites that want to maintain user's logged-in # session after the user arrives from an external link". In practice, # Safari (both iOS and macOS) does not send a SameSite=lax cookie when # following a link from an external site. So, marudor.de providing a # checkin link to travelynx.de/s/whatever does not work because the user # is not logged in due to Safari not sending the cookie. # # This looks a lot like a Safari bug, but we can't do anything about it. So # we don't set the SameSite flag at all for now. # # --derf, 2019-05-01 $self->sessions->samesite(undef); $self->defaults( layout => 'default' ); $self->hook( before_dispatch => sub { my ($self) = @_; # The "theme" cookie is set client-side if the theme we delivered was # changed by dark mode detection or by using the theme switcher. It's # not part of Mojolicious' session data (and can't be, due to # signing and HTTPOnly), so we need to add it here. for my $cookie ( @{ $self->req->cookies } ) { if ( $cookie->name eq 'theme' ) { $self->session( theme => $cookie->value ); return; } } } ); $self->attr( cache_iris_main => sub { my ($self) = @_; return Cache::File->new( cache_root => $self->app->config->{cache}->{schedule}, default_expires => '6 hours', lock_level => Cache::File::LOCK_LOCAL(), ); } ); $self->attr( cache_iris_rt => sub { my ($self) = @_; return Cache::File->new( cache_root => $self->app->config->{cache}->{realtime}, default_expires => '70 seconds', lock_level => Cache::File::LOCK_LOCAL(), ); } ); $self->attr( token_type => sub { return { status => 1, history => 2, travel => 3, import => 4, }; } ); $self->attr( token_types => sub { return [qw(status history travel import)]; } ); $self->attr( account_public_mask => sub { return { status_intern => 0x01, status_extern => 0x02, status_comment => 0x04, history_intern => 0x10, history_latest => 0x20, history_full => 0x40, }; } ); $self->attr( journey_edit_mask => sub { return { sched_departure => 0x0001, real_departure => 0x0002, from_station => 0x0004, route => 0x0010, is_cancelled => 0x0020, sched_arrival => 0x0100, real_arrival => 0x0200, to_station => 0x0400, }; } ); $self->attr( coordinates_by_station => sub { my $legacy_names = $self->app->renamed_station; my %location; for my $station ( Travel::Status::DE::IRIS::Stations::get_stations() ) { if ( $station->[3] ) { $location{ $station->[1] } = [ $station->[4], $station->[3] ]; } } while ( my ( $old_name, $new_name ) = each %{$legacy_names} ) { $location{$old_name} = $location{$new_name}; } return \%location; } ); # https://de.wikipedia.org/wiki/Liste_nach_Gemeinden_und_Regionen_benannter_IC/ICE-Fahrzeuge#Namensgebung_ICE-Triebz%C3%BCge_nach_Gemeinden # via https://github.com/marudor/BahnhofsAbfahrten/blob/master/src/server/Reihung/ICENaming.ts $self->attr( ice_name => sub { my $id_to_name = JSON->new->utf8->decode( scalar read_file('share/ice_names.json') ); return $id_to_name; } ); $self->attr( renamed_station => sub { my $legacy_to_new = JSON->new->utf8->decode( scalar read_file('share/old_station_names.json') ); return $legacy_to_new; } ); $self->attr( station_by_eva => sub { my %map; for my $station ( Travel::Status::DE::IRIS::Stations::get_stations() ) { $map{ $station->[2] } = $station; } return \%map; } ); $self->helper( sendmail => sub { state $sendmail = Travelynx::Helper::Sendmail->new( config => ( $self->config->{mail} // {} ), log => $self->log ); } ); $self->helper( pg => sub { my ($self) = @_; my $config = $self->app->config; my $dbname = $config->{db}->{database}; my $host = $config->{db}->{host} // 'localhost'; my $port = $config->{db}->{port} // 5432; my $user = $config->{db}->{user}; my $pw = $config->{db}->{password}; state $pg = Mojo::Pg->new("postgresql://${user}\@${host}:${port}/${dbname}") ->password($pw); } ); $self->helper( 'now' => sub { return DateTime->now( time_zone => 'Europe/Berlin' ); } ); $self->helper( 'numify_skipped_stations' => sub { my ( $self, $count ) = @_; if ( $count == 0 ) { return 'INTERNAL ERROR'; } if ( $count == 1 ) { return 'Eine Station ohne Geokoordinaten wurde nicht berücksichtigt.'; } return "${count} Stationen ohne Geookordinaten wurden nicht berücksichtigt."; } ); $self->helper( 'get_departures' => sub { my ( $self, $station, $lookbehind, $lookahead, $with_related ) = @_; $lookbehind //= 180; $lookahead //= 30; $with_related //= 0; my @station_matches = Travel::Status::DE::IRIS::Stations::get_station($station); if ( @station_matches == 1 ) { $station = $station_matches[0][0]; my $status = Travel::Status::DE::IRIS->new( station => $station, main_cache => $self->app->cache_iris_main, realtime_cache => $self->app->cache_iris_rt, keep_transfers => 1, lookbehind => 20, datetime => DateTime->now( time_zone => 'Europe/Berlin' ) ->subtract( minutes => $lookbehind ), lookahead => $lookbehind + $lookahead, lwp_options => { timeout => 10, agent => 'travelynx/' . $self->app->config->{version}, }, with_related => $with_related, ); return { results => [ $status->results ], errstr => $status->errstr, station_ds100 => ( $status->station ? $status->station->{ds100} : undef ), station_eva => ( $status->station ? $status->station->{uic} : undef ), station_name => ( $status->station ? $status->station->{name} : undef ), related_stations => [ $status->related_stations ], }; } elsif ( @station_matches > 1 ) { return { results => [], errstr => 'Mehrdeutiger Stationsname. Mögliche Eingaben: ' . join( q{, }, map { $_->[1] } @station_matches ), }; } else { return { results => [], errstr => 'Unbekannte Station', }; } } ); $self->helper( 'grep_unknown_stations' => sub { my ( $self, @stations ) = @_; my @unknown_stations; for my $station (@stations) { my $station_info = get_station($station); if ( not $station_info ) { push( @unknown_stations, $station ); } } return @unknown_stations; } ); # Returns (journey id, error) # Must be called during a transaction. # Must perform a rollback on error. $self->helper( 'add_journey' => sub { my ( $self, %opt ) = @_; my $db = $opt{db}; my $uid = $opt{uid} // $self->current_user->{id}; my $now = DateTime->now( time_zone => 'Europe/Berlin' ); my $dep_station = get_station( $opt{dep_station} ); my $arr_station = get_station( $opt{arr_station} ); if ( not $dep_station ) { return ( undef, 'Unbekannter Startbahnhof' ); } if ( not $arr_station ) { return ( undef, 'Unbekannter Zielbahnhof' ); } my $daily_journey_count = $db->select( 'journeys_str', 'count(*) as count', { user_id => $uid, real_dep_ts => { -between => [ $opt{rt_departure}->clone->subtract( days => 1 ) ->epoch, $opt{rt_departure}->epoch ], }, } )->hash->{count}; if ( $daily_journey_count >= 100 ) { return ( undef, "In den 24 Stunden vor der angegebenen Abfahrtszeit wurden ${daily_journey_count} weitere Fahrten angetreten. Das kann nicht stimmen." ); } my @route = ( [ $dep_station->[1], {}, undef ] ); if ( $opt{route} ) { my @unknown_stations; for my $station ( @{ $opt{route} } ) { my $station_info = get_station($station); if ($station_info) { push( @route, [ $station_info->[1], {}, undef ] ); } else { push( @route, [ $station, {}, undef ] ); push( @unknown_stations, $station ); } } if ( not $opt{lax} ) { if ( @unknown_stations == 1 ) { return ( undef, "Unbekannter Unterwegshalt: $unknown_stations[0]" ); } elsif (@unknown_stations) { return ( undef, 'Unbekannte Unterwegshalte: ' . join( ', ', @unknown_stations ) ); } } } push( @route, [ $arr_station->[1], {}, undef ] ); if ( $route[0][0] eq $route[1][0] ) { shift(@route); } if ( $route[-2][0] eq $route[-1][0] ) { pop(@route); } my $entry = { user_id => $uid, train_type => $opt{train_type}, train_line => $opt{train_line}, train_no => $opt{train_no}, train_id => 'manual', checkin_station_id => $dep_station->[2], checkin_time => $now, sched_departure => $opt{sched_departure}, real_departure => $opt{rt_departure}, checkout_station_id => $arr_station->[2], sched_arrival => $opt{sched_arrival}, real_arrival => $opt{rt_arrival}, checkout_time => $now, edited => 0x3fff, cancelled => $opt{cancelled} ? 1 : 0, route => JSON->new->encode( \@route ), }; if ( $opt{comment} ) { $entry->{user_data} = JSON->new->encode( { comment => $opt{comment} } ); } my $journey_id = undef; eval { $journey_id = $db->insert( 'journeys', $entry, { returning => 'id' } ) ->hash->{id}; $self->invalidate_stats_cache( $opt{rt_departure}, $db, $uid ); }; if ($@) { $self->app->log->error("add_journey($uid): $@"); return ( undef, 'add_journey failed: ' . $@ ); } return ( $journey_id, undef ); } ); $self->helper( 'checkin' => sub { my ( $self, $station, $train_id, $uid ) = @_; $uid //= $self->current_user->{id}; my $status = $self->get_departures( $station, 140, 40, 0 ); if ( $status->{errstr} ) { return ( undef, $status->{errstr} ); } else { my ($train) = List::Util::first { $_->train_id eq $train_id } @{ $status->{results} }; if ( not defined $train ) { return ( undef, "Train ${train_id} not found" ); } else { my $user = $self->get_user_status($uid); if ( $user->{checked_in} or $user->{cancelled} ) { if ( $user->{train_id} eq $train_id and $user->{dep_eva} eq $status->{station_eva} ) { # checking in twice is harmless return ( $train, undef ); } # Otherwise, someone forgot to check out first $self->checkout( $station, 1, $uid ); } eval { my $json = JSON->new; $self->pg->db->insert( 'in_transit', { user_id => $uid, cancelled => $train->departure_is_cancelled ? 1 : 0, checkin_station_id => $status->{station_eva}, checkin_time => DateTime->now( time_zone => 'Europe/Berlin' ), dep_platform => $train->platform, train_type => $train->type, train_line => $train->line_no, train_no => $train->train_no, train_id => $train->train_id, sched_departure => $train->sched_departure, real_departure => $train->departure, route => $json->encode( [ $self->route_diff($train) ] ), messages => $json->encode( [ map { [ $_->[0]->epoch, $_->[1] ] } $train->messages ] ) } ); }; if ($@) { $self->app->log->error( "Checkin($uid): INSERT failed: $@"); return ( undef, 'INSERT failed: ' . $@ ); } $self->add_route_timestamps( $uid, $train, 1 ); $self->run_hook( $uid, 'checkin' ); return ( $train, undef ); } } } ); $self->helper( 'undo' => sub { my ( $self, $journey_id, $uid ) = @_; $uid //= $self->current_user->{id}; if ( $journey_id eq 'in_transit' ) { eval { $self->pg->db->delete( 'in_transit', { user_id => $uid } ); }; if ($@) { $self->app->log->error("Undo($uid, $journey_id): $@"); return "Undo($journey_id): $@"; } $self->run_hook( $uid, 'undo' ); return undef; } if ( $journey_id !~ m{ ^ \d+ $ }x ) { return 'Invalid Journey ID'; } eval { my $db = $self->pg->db; my $tx = $db->begin; my $journey = $db->select( 'journeys', '*', { user_id => $uid, id => $journey_id } )->hash; $db->delete( 'journeys', { user_id => $uid, id => $journey_id } ); if ( $journey->{edited} ) { die( "Cannot undo a journey which has already been edited. Please delete manually.\n" ); } delete $journey->{edited}; delete $journey->{id}; $db->insert( 'in_transit', $journey ); my $cache_ts = DateTime->now( time_zone => 'Europe/Berlin' ); if ( $journey->{real_departure} =~ m{ ^ (? \d{4} ) - (? \d{2} ) }x ) { $cache_ts->set( year => $+{year}, month => $+{month} ); } $self->invalidate_stats_cache( $cache_ts, $db, $uid ); $tx->commit; }; if ($@) { $self->app->log->error("Undo($uid, $journey_id): $@"); return "Undo($journey_id): $@"; } $self->run_hook( $uid, 'undo' ); return undef; } ); # Statistics are partitioned by real_departure, which must be provided # when calling this function e.g. after journey deletion or editing. # If a joureny's real_departure has been edited, this function must be # called twice: once with the old and once with the new value. $self->helper( 'invalidate_stats_cache' => sub { my ( $self, $ts, $db, $uid ) = @_; $uid //= $self->current_user->{id}; $db //= $self->pg->db; $self->pg->db->delete( 'journey_stats', { user_id => $uid, year => $ts->year, month => $ts->month, } ); $self->pg->db->delete( 'journey_stats', { user_id => $uid, year => $ts->year, month => 0, } ); } ); $self->helper( 'checkout' => sub { my ( $self, $station, $force, $uid ) = @_; my $db = $self->pg->db; my $status = $self->get_departures( $station, 120, 120, 0 ); $uid //= $self->current_user->{id}; my $user = $self->get_user_status($uid); my $train_id = $user->{train_id}; if ( not $user->{checked_in} and not $user->{cancelled} ) { return ( 0, 'You are not checked into any train' ); } if ( $status->{errstr} and not $force ) { return ( 1, $status->{errstr} ); } my $now = DateTime->now( time_zone => 'Europe/Berlin' ); my $journey = $db->select( 'in_transit', '*', { user_id => $uid } ) ->expand->hash; # Note that a train may pass the same station several times. # Notable example: S41 / S42 ("Ringbahn") both starts and # terminates at Berlin Südkreuz my ($train) = List::Util::first { $_->train_id eq $train_id and $_->sched_arrival and $_->sched_arrival->epoch > $user->{sched_departure}->epoch } @{ $status->{results} }; $train //= List::Util::first { $_->train_id eq $train_id } @{ $status->{results} }; my $new_checkout_station_id = $status->{station_eva}; # When a checkout is triggered by a checkin, there is an edge case # with related stations. # Assume a user travels from A to B1, then from B2 to C. B1 and B2 are # relatd stations (e.g. "Frankfurt Hbf" and "Frankfurt Hbf(tief)"). # Now, if they check in for the journey from B2 to C, and have not yet # checked out of the previous train, $train is undef as B2 is not B1. # Redo the request with with_related => 1 to avoid this case. # While at it, we increase the lookahead to handle long journeys as # well. if ( not $train ) { $status = $self->get_departures( $station, 120, 180, 1 ); ($train) = List::Util::first { $_->train_id eq $train_id } @{ $status->{results} }; if ( $train and $self->app->station_by_eva->{ $train->station_uic } ) { $new_checkout_station_id = $train->station_uic; } } # Store the intended checkout station regardless of this operation's # success. $db->update( 'in_transit', { checkout_station_id => $new_checkout_station_id, }, { user_id => $uid } ); # If in_transit already contains arrival data for another estimated # destination, we must invalidate it. if ( defined $journey->{checkout_station_id} and $journey->{checkout_station_id} != $new_checkout_station_id ) { $db->update( 'in_transit', { checkout_time => undef, arr_platform => undef, sched_arrival => undef, real_arrival => undef, }, { user_id => $uid } ); } if ( not defined $train ) { # Arrival time via IRIS is unknown, so the train probably has not # arrived yet. Fall back to HAFAS. # TODO support cases where $station is EVA or DS100 code if ( my $station_data = List::Util::first { $_->[0] eq $station } @{ $journey->{route} } ) { $station_data = $station_data->[1]; if ( $station_data->{sched_arr} ) { my $sched_arr = epoch_to_dt( $station_data->{sched_arr} ); my $rt_arr = $sched_arr->clone; if ( $station_data->{adelay} and $station_data->{adelay} =~ m{^\d+$} ) { $rt_arr->add( minutes => $station_data->{adelay} ); } $db->update( 'in_transit', { sched_arrival => $sched_arr, real_arrival => $rt_arr }, { user_id => $uid } ); } } if ( not $force ) { $self->run_hook( $uid, 'update' ); return ( 1, undef ); } } my $has_arrived = 0; eval { my $tx = $db->begin; if ( defined $train and not $train->arrival and not $force ) { my $train_no = $train->train_no; die("Train ${train_no} has no arrival timestamp\n"); } elsif ( defined $train and $train->arrival ) { $has_arrived = $train->arrival->epoch < $now->epoch ? 1 : 0; my $json = JSON->new; $db->update( 'in_transit', { checkout_time => $now, arr_platform => $train->platform, sched_arrival => $train->sched_arrival, real_arrival => $train->arrival, route => $json->encode( [ $self->route_diff($train) ] ), messages => $json->encode( [ map { [ $_->[0]->epoch, $_->[1] ] } $train->messages ] ) }, { user_id => $uid } ); if ($has_arrived) { my @unknown_stations = $self->grep_unknown_stations( $train->route ); if (@unknown_stations) { $self->app->log->warn( 'Encountered unknown stations: ' . join( ', ', @unknown_stations ) ); } } } $journey = $db->select( 'in_transit', '*', { user_id => $uid } )->hash; if ( $has_arrived or $force ) { delete $journey->{data}; $journey->{edited} = 0; $journey->{checkout_time} = $now; $db->insert( 'journeys', $journey ); $db->delete( 'in_transit', { user_id => $uid } ); my $cache_ts = $now->clone; if ( $journey->{real_departure} =~ m{ ^ (? \d{4} ) - (? \d{2} ) }x ) { $cache_ts->set( year => $+{year}, month => $+{month} ); } $self->invalidate_stats_cache( $cache_ts, $db, $uid ); } elsif ( defined $train and $train->arrival_is_cancelled ) { # This branch is only taken if the deparure was not cancelled, # i.e., if the train was supposed to go here but got # redirected or cancelled on the way and not from the start on. # If the departure itself was cancelled, the user route is # cancelled_from action -> 'cancelled journey' panel on main page # -> cancelled_to action -> force checkout (causing the # previous branch to be taken due to $force) $journey->{edited} = 0; $journey->{checkout_time} = $now; $journey->{cancelled} = 1; delete $journey->{data}; $db->insert( 'journeys', $journey ); $journey = $db->select( 'in_transit', ['data'], { user_id => $uid } )->expand->hash; $journey->{data}{cancelled_destination} = $train->station; $db->update( 'in_transit', { checkout_station_id => undef, checkout_time => undef, arr_platform => undef, sched_arrival => undef, real_arrival => undef, data => JSON->new->encode( $journey->{data} ), }, { user_id => $uid } ); } $tx->commit; }; if ($@) { $self->app->log->error("Checkout($uid): $@"); return ( 1, 'Checkout error: ' . $@ ); } if ( $has_arrived or $force ) { $self->run_hook( $uid, 'checkout' ); return ( 0, undef ); } $self->run_hook( $uid, 'update' ); $self->add_route_timestamps( $uid, $train, 0 ); return ( 1, undef ); } ); $self->helper( 'mark_seen' => sub { my ( $self, $uid ) = @_; $self->pg->db->update( 'users', { last_seen => DateTime->now( time_zone => 'Europe/Berlin' ) }, { id => $uid } ); } ); $self->helper( 'update_in_transit_comment' => sub { my ( $self, $comment, $uid ) = @_; $uid //= $self->current_user->{id}; my $status = $self->pg->db->select( 'in_transit', ['user_data'], { user_id => $uid } )->expand->hash; if ( not $status ) { return; } $status->{user_data}{comment} = $comment; $self->pg->db->update( 'in_transit', { user_data => JSON->new->encode( $status->{user_data} ) }, { user_id => $uid } ); } ); $self->helper( 'update_journey_part' => sub { my ( $self, $db, $journey_id, $key, $value ) = @_; my $rows; my $journey = $self->get_journey( db => $db, journey_id => $journey_id, with_datetime => 1, ); eval { if ( $key eq 'from_name' ) { my $from_station = get_station( $value, 1 ); if ( not $from_station ) { die("Unbekannter Startbahnhof\n"); } $rows = $db->update( 'journeys', { checkin_station_id => $from_station->[2], edited => $journey->{edited} | 0x0004, }, { id => $journey_id, } )->rows; } elsif ( $key eq 'to_name' ) { my $to_station = get_station( $value, 1 ); if ( not $to_station ) { die("Unbekannter Zielbahnhof\n"); } $rows = $db->update( 'journeys', { checkout_station_id => $to_station->[2], edited => $journey->{edited} | 0x0400, }, { id => $journey_id, } )->rows; } elsif ( $key eq 'sched_departure' ) { $rows = $db->update( 'journeys', { sched_departure => $value, edited => $journey->{edited} | 0x0001, }, { id => $journey_id, } )->rows; } elsif ( $key eq 'rt_departure' ) { $rows = $db->update( 'journeys', { real_departure => $value, edited => $journey->{edited} | 0x0002, }, { id => $journey_id, } )->rows; # stats are partitioned by rt_departure -> both the cache for # the old value (see bottom of this function) and the new value # (here) must be invalidated. $self->invalidate_stats_cache( $value, $db ); } elsif ( $key eq 'sched_arrival' ) { $rows = $db->update( 'journeys', { sched_arrival => $value, edited => $journey->{edited} | 0x0100, }, { id => $journey_id, } )->rows; } elsif ( $key eq 'rt_arrival' ) { $rows = $db->update( 'journeys', { real_arrival => $value, edited => $journey->{edited} | 0x0200, }, { id => $journey_id, } )->rows; } elsif ( $key eq 'route' ) { my @new_route = map { [ $_, {}, undef ] } @{$value}; $rows = $db->update( 'journeys', { route => JSON->new->encode( \@new_route ), edited => $journey->{edited} | 0x0010, }, { id => $journey_id, } )->rows; } elsif ( $key eq 'cancelled' ) { $rows = $db->update( 'journeys', { cancelled => $value, edited => $journey->{edited} | 0x0020, }, { id => $journey_id, } )->rows; } elsif ( $key eq 'comment' ) { $journey->{user_data}{comment} = $value; $rows = $db->update( 'journeys', { user_data => JSON->new->encode( $journey->{user_data} ), }, { id => $journey_id, } )->rows; } else { die("Invalid key $key\n"); } }; if ($@) { $self->app->log->error( "update_journey_part($journey_id, $key): $@"); return "update_journey_part($key): $@"; } if ( $rows == 1 ) { $self->invalidate_stats_cache( $journey->{rt_departure}, $db ); return undef; } return 'UPDATE failed: did not match any journey part'; } ); $self->helper( 'journey_sanity_check' => sub { my ( $self, $journey, $lax ) = @_; if ( defined $journey->{sched_duration} and $journey->{sched_duration} <= 0 ) { return 'Die geplante Dauer dieser Zugfahrt ist ≤ 0. Teleportation und Zeitreisen werden aktuell nicht unterstützt.'; } if ( defined $journey->{rt_duration} and $journey->{rt_duration} <= 0 ) { return 'Die Dauer dieser Zugfahrt ist ≤ 0. Teleportation und Zeitreisen werden aktuell nicht unterstützt.'; } if ( $journey->{sched_duration} and $journey->{sched_duration} > 60 * 60 * 24 ) { return 'Die Zugfahrt ist länger als 24 Stunden.'; } if ( $journey->{rt_duration} and $journey->{rt_duration} > 60 * 60 * 24 ) { return 'Die Zugfahrt ist länger als 24 Stunden.'; } if ( $journey->{kmh_route} > 500 or $journey->{kmh_beeline} > 500 ) { return 'Zugfahrten mit über 500 km/h? Schön wär\'s.'; } if ( $journey->{route} and @{ $journey->{route} } > 99 ) { my $stop_count = @{ $journey->{route} }; return "Die Zugfahrt hat $stop_count Unterwegshalte. Also ich weiß ja nicht so recht."; } if ( $journey->{edited} & 0x0010 and not $lax ) { my @unknown_stations = $self->grep_unknown_stations( map { $_->[0] } @{ $journey->{route} } ); if (@unknown_stations) { return 'Unbekannte Station(en): ' . join( ', ', @unknown_stations ); } } return undef; } ); $self->helper( 'verify_registration_token' => sub { my ( $self, $uid, $token ) = @_; my $db = $self->pg->db; my $tx = $db->begin; my $res = $db->select( 'pending_registrations', 'count(*) as count', { user_id => $uid, token => $token } ); if ( $res->hash->{count} ) { $db->update( 'users', { status => 1 }, { id => $uid } ); $db->delete( 'pending_registrations', { user_id => $uid } ); $tx->commit; return 1; } return; } ); $self->helper( 'get_uid_by_name_and_mail' => sub { my ( $self, $name, $email ) = @_; my $res = $self->pg->db->select( 'users', ['id'], { name => $name, email => $email, status => 1 } ); if ( my $user = $res->hash ) { return $user->{id}; } return; } ); $self->helper( 'get_privacy_by_name' => sub { my ( $self, $name ) = @_; my $res = $self->pg->db->select( 'users', [ 'id', 'public_level' ], { name => $name, status => 1 } ); if ( my $user = $res->hash ) { return $user; } return; } ); $self->helper( 'set_privacy' => sub { my ( $self, $uid, $public_level ) = @_; $self->pg->db->update( 'users', { public_level => $public_level }, { id => $uid } ); } ); $self->helper( 'mark_for_password_reset' => sub { my ( $self, $db, $uid, $token ) = @_; my $res = $db->select( 'pending_passwords', 'count(*) as count', { user_id => $uid } ); if ( $res->hash->{count} ) { return 'in progress'; } $db->insert( 'pending_passwords', { user_id => $uid, token => $token, requested_at => DateTime->now( time_zone => 'Europe/Berlin' ) } ); return undef; } ); $self->helper( 'verify_password_token' => sub { my ( $self, $uid, $token ) = @_; my $res = $self->pg->db->select( 'pending_passwords', 'count(*) as count', { user_id => $uid, token => $token } ); if ( $res->hash->{count} ) { return 1; } return; } ); $self->helper( 'mark_for_mail_change' => sub { my ( $self, $db, $uid, $email, $token ) = @_; $db->insert( 'pending_mails', { user_id => $uid, email => $email, token => $token, requested_at => DateTime->now( time_zone => 'Europe/Berlin' ) }, { on_conflict => \ '(user_id) do update set email = EXCLUDED.email, token = EXCLUDED.token, requested_at = EXCLUDED.requested_at' }, ); } ); $self->helper( 'change_mail_with_token' => sub { my ( $self, $uid, $token ) = @_; my $db = $self->pg->db; my $tx = $db->begin; my $res_h = $db->select( 'pending_mails', ['email'], { user_id => $uid, token => $token } )->hash; if ($res_h) { $db->update( 'users', { email => $res_h->{email} }, { id => $uid } ); $db->delete( 'pending_mails', { user_id => $uid } ); $tx->commit; return 1; } return; } ); $self->helper( 'remove_password_token' => sub { my ( $self, $uid, $token ) = @_; $self->pg->db->delete( 'pending_passwords', { user_id => $uid, token => $token } ); } ); # This helper should only be called directly when also providing a user ID. # If you don't have one, use current_user() instead (get_user_data will # delegate to it anyways). $self->helper( 'get_user_data' => sub { my ( $self, $uid ) = @_; $uid //= $self->current_user->{id}; my $user_data = $self->pg->db->select( 'users', 'id, name, status, public_level, email, ' . 'extract(epoch from registered_at) as registered_at_ts, ' . 'extract(epoch from last_seen) as last_seen_ts, ' . 'extract(epoch from deletion_requested) as deletion_requested_ts', { id => $uid } )->hash; if ($user_data) { return { id => $user_data->{id}, name => $user_data->{name}, status => $user_data->{status}, is_public => $user_data->{public_level}, email => $user_data->{email}, registered_at => DateTime->from_epoch( epoch => $user_data->{registered_at_ts}, time_zone => 'Europe/Berlin' ), last_seen => DateTime->from_epoch( epoch => $user_data->{last_seen_ts}, time_zone => 'Europe/Berlin' ), deletion_requested => $user_data->{deletion_requested_ts} ? DateTime->from_epoch( epoch => $user_data->{deletion_requested_ts}, time_zone => 'Europe/Berlin' ) : undef, }; } return undef; } ); $self->helper( 'get_api_token' => sub { my ( $self, $uid ) = @_; $uid //= $self->current_user->{id}; my $token = {}; my $res = $self->pg->db->select( 'tokens', [ 'type', 'token' ], { user_id => $uid } ); for my $entry ( $res->hashes->each ) { $token->{ $self->app->token_types->[ $entry->{type} - 1 ] } = $entry->{token}; } return $token; } ); $self->helper( 'get_webhook' => sub { my ( $self, $uid ) = @_; $uid //= $self->current_user->{id}; my $res_h = $self->pg->db->select( 'webhooks_str', '*', { user_id => $uid } )->hash; $res_h->{latest_run} = epoch_to_dt( $res_h->{latest_run_ts} ); return $res_h; } ); $self->helper( 'set_webhook' => sub { my ( $self, %opt ) = @_; $opt{uid} //= $self->current_user->{id}; if ( $opt{token} ) { $opt{token} =~ tr{\r\n}{}d; } my $res = $self->pg->db->insert( 'webhooks', { user_id => $opt{uid}, enabled => $opt{enabled}, url => $opt{url}, token => $opt{token} }, { on_conflict => \ '(user_id) do update set enabled = EXCLUDED.enabled, url = EXCLUDED.url, token = EXCLUDED.token, errored = null, latest_run = null, output = null' } ); } ); $self->helper( 'mark_hook_status' => sub { my ( $self, $uid, $url, $success, $text ) = @_; if ( length($text) > 1000 ) { $text = substr( $text, 0, 1000 ) . '…'; } $self->pg->db->update( 'webhooks', { errored => $success ? 0 : 1, latest_run => DateTime->now( time_zone => 'Europe/Berlin' ), output => $text, }, { user_id => $uid, url => $url } ); } ); $self->helper( 'run_hook' => sub { my ( $self, $uid, $reason, $callback ) = @_; my $hook = $self->get_webhook($uid); if ( not $hook->{enabled} or not $hook->{url} =~ m{^ https?:// }x ) { if ($callback) { &$callback(); } return; } my $status = $self->get_user_status_json_v1($uid); my $header = {}; my $hook_body = { reason => $reason, status => $status, }; if ( $hook->{token} ) { $header->{Authorization} = "Bearer $hook->{token}"; $header->{'User-Agent'} = 'travelynx/' . $self->app->config->{version}; } my $ua = $self->ua; if ($callback) { $ua->request_timeout(4); } else { $ua->request_timeout(10); } $ua->post_p( $hook->{url} => $header => json => $hook_body )->then( sub { my ($tx) = @_; if ( my $err = $tx->error ) { $self->mark_hook_status( $uid, $hook->{url}, 0, "HTTP $err->{code} $err->{message}" ); } else { $self->mark_hook_status( $uid, $hook->{url}, 1, $tx->result->body ); } if ($callback) { &$callback(); } } )->catch( sub { my ($err) = @_; $self->mark_hook_status( $uid, $hook->{url}, 0, $err ); if ($callback) { &$callback(); } } )->wait; } ); $self->helper( 'get_user_password' => sub { my ( $self, $name ) = @_; my $res_h = $self->pg->db->select( 'users', 'id, name, status, password as password_hash', { name => $name } )->hash; return $res_h; } ); $self->helper( 'add_user' => sub { my ( $self, $db, $user_name, $email, $token, $password ) = @_; # This helper must be called during a transaction, as user creation # may fail even after the database entry has been generated, e.g. if # the registration mail cannot be sent. We therefore use $db (the # database handle performing the transaction) instead of $self->pg->db # (which may be a new handle not belonging to the transaction). my $now = DateTime->now( time_zone => 'Europe/Berlin' ); my $res = $db->insert( 'users', { name => $user_name, status => 0, public_level => 0, email => $email, password => $password, registered_at => $now, last_seen => $now, }, { returning => 'id' } ); my $uid = $res->hash->{id}; $db->insert( 'pending_registrations', { user_id => $uid, token => $token } ); return $uid; } ); $self->helper( 'flag_user_deletion' => sub { my ( $self, $uid ) = @_; my $now = DateTime->now( time_zone => 'Europe/Berlin' ); $self->pg->db->update( 'users', { deletion_requested => $now }, { id => $uid, } ); } ); $self->helper( 'unflag_user_deletion' => sub { my ( $self, $uid ) = @_; $self->pg->db->update( 'users', { deletion_requested => undef, }, { id => $uid, } ); } ); $self->helper( 'set_user_password' => sub { my ( $self, $uid, $password ) = @_; $self->pg->db->update( 'users', { password => $password }, { id => $uid } ); } ); $self->helper( 'check_if_user_name_exists' => sub { my ( $self, $user_name ) = @_; my $count = $self->pg->db->select( 'users', 'count(*) as count', { name => $user_name } )->hash->{count}; if ($count) { return 1; } return 0; } ); $self->helper( 'check_if_mail_is_blacklisted' => sub { my ( $self, $mail ) = @_; my $count = $self->pg->db->select( 'users', 'count(*) as count', { email => $mail, status => 0, } )->hash->{count}; if ($count) { return 1; } $count = $self->pg->db->select( 'mail_blacklist', 'count(*) as count', { email => $mail, num_tries => { '>', 1 }, } )->hash->{count}; if ($count) { return 1; } return 0; } ); $self->helper( 'delete_journey' => sub { my ( $self, $journey_id, $checkin_epoch, $checkout_epoch ) = @_; my $uid = $self->current_user->{id}; my @journeys = $self->get_user_travels( uid => $uid, journey_id => $journey_id ); if ( @journeys == 0 ) { return 'Journey not found'; } my $journey = $journeys[0]; # Double-check (comparing both ID and action epoch) to make sure we # are really deleting the right journey and the user isn't just # playing around with POST requests. if ( $journey->{id} != $journey_id or $journey->{checkin_ts} != $checkin_epoch or $journey->{checkout_ts} != $checkout_epoch ) { return 'Invalid journey data'; } my $rows; eval { $rows = $self->pg->db->delete( 'journeys', { user_id => $uid, id => $journey_id, } )->rows; }; if ($@) { $self->app->log->error("Delete($uid, $journey_id): $@"); return 'DELETE failed: ' . $@; } if ( $rows == 1 ) { $self->invalidate_stats_cache( epoch_to_dt( $journey->{rt_dep_ts} ) ); return undef; } return sprintf( 'Deleted %d rows, expected 1', $rows ); } ); $self->helper( 'get_journey_stats' => sub { my ( $self, %opt ) = @_; if ( $opt{cancelled} ) { $self->app->log->warn( 'get_journey_stats called with illegal option cancelled => 1' ); return {}; } my $uid = $opt{uid} // $self->current_user->{id}; my $year = $opt{year} // 0; my $month = $opt{month} // 0; # Assumption: If the stats cache contains an entry it is up-to-date. # -> Cache entries must be explicitly invalidated whenever the user # checks out of a train or manually edits/adds a journey. my $res = $self->pg->db->select( 'journey_stats', ['data'], { user_id => $uid, year => $year, month => $month } ); my $res_h = $res->expand->hash; if ($res_h) { $res->finish; return $res_h->{data}; } my $interval_start = DateTime->new( time_zone => 'Europe/Berlin', year => 2000, month => 1, day => 1, hour => 0, minute => 0, second => 0, ); # I wonder if people will still be traveling by train in the year 3000 my $interval_end = $interval_start->clone->add( years => 1000 ); if ( $opt{year} and $opt{month} ) { $interval_start->set( year => $opt{year}, month => $opt{month} ); $interval_end = $interval_start->clone->add( months => 1 ); } elsif ( $opt{year} ) { $interval_start->set( year => $opt{year} ); $interval_end = $interval_start->clone->add( years => 1 ); } my @journeys = $self->get_user_travels( uid => $uid, cancelled => $opt{cancelled} ? 1 : 0, verbose => 1, with_polyline => 1, after => $interval_start, before => $interval_end ); my $stats = $self->compute_journey_stats(@journeys); eval { $self->pg->db->insert( 'journey_stats', { user_id => $uid, year => $year, month => $month, data => JSON->new->encode($stats), } ); }; if ( my $err = $@ ) { if ( $err =~ m{duplicate key value violates unique constraint} ) { # When a user opens the same history page several times in # short succession, there is a race condition where several # Mojolicious workers execute this helper, notice that there is # no up-to-date history, compute it, and insert it using the # statement above. This will lead to a uniqueness violation # in each successive insert. However, this is harmless, and # thus ignored. } else { # Otherwise we probably have a problem. die($@); } } return $stats; } ); $self->helper( 'history_years' => sub { my ( $self, $uid ) = @_; $uid //= $self->current_user->{id}, my $res = $self->pg->db->select( 'journeys', 'distinct extract(year from real_departure) as year', { user_id => $uid }, { order_by => { -asc => 'year' } } ); my @ret; for my $row ( $res->hashes->each ) { push( @ret, [ $row->{year}, $row->{year} ] ); } return @ret; } ); $self->helper( 'history_months' => sub { my ( $self, $uid ) = @_; $uid //= $self->current_user->{id}, my $res = $self->pg->db->select( 'journeys', "distinct to_char(real_departure, 'YYYY.MM') as yearmonth", { user_id => $uid }, { order_by => { -asc => 'yearmonth' } } ); my @ret; for my $row ( $res->hashes->each ) { my ( $year, $month ) = split( qr{[.]}, $row->{yearmonth} ); push( @ret, [ "${year}/${month}", "${month}.${year}" ] ); } return @ret; } ); $self->helper( 'route_diff' => sub { my ( $self, $train ) = @_; my @json_route; my @route = $train->route; my @sched_route = $train->sched_route; my $route_idx = 0; my $sched_idx = 0; while ( $route_idx <= $#route and $sched_idx <= $#sched_route ) { if ( $route[$route_idx] eq $sched_route[$sched_idx] ) { push( @json_route, [ $route[$route_idx], {}, undef ] ); $route_idx++; $sched_idx++; } # this branch is inefficient, but won't be taken frequently elsif ( not( grep { $_ eq $route[$route_idx] } @sched_route ) ) { push( @json_route, [ $route[$route_idx], {}, 'additional' ], ); $route_idx++; } else { push( @json_route, [ $sched_route[$sched_idx], {}, 'cancelled' ], ); $sched_idx++; } } while ( $route_idx <= $#route ) { push( @json_route, [ $route[$route_idx], {}, 'additional' ], ); $route_idx++; } while ( $sched_idx <= $#sched_route ) { push( @json_route, [ $sched_route[$sched_idx], {}, 'cancelled' ], ); $sched_idx++; } return @json_route; } ); $self->helper( 'get_dbdb_station_p' => sub { my ( $self, $eva ) = @_; my $url = "https://lib.finalrewind.org/dbdb/s/${eva}.json"; my $cache = $self->app->cache_iris_main; my $promise = Mojo::Promise->new; if ( my $content = $cache->thaw($url) ) { $promise->resolve($content); return $promise; } $self->ua->request_timeout(5)->get_p($url)->then( sub { my ($tx) = @_; my $body = decode( 'utf-8', $tx->res->body ); my $json = JSON->new->decode($body); $cache->freeze( $url, $json ); $promise->resolve($json); } )->catch( sub { my ($err) = @_; $promise->reject($err); } )->wait; return $promise; } ); $self->helper( 'has_wagonorder_p' => sub { my ( $self, $ts, $train_no ) = @_; my $api_ts = $ts->strftime('%Y%m%d%H%M'); my $url = "https://lib.finalrewind.org/dbdb/has_wagonorder/${train_no}/${api_ts}"; my $cache = $self->app->cache_iris_main; my $promise = Mojo::Promise->new; if ( my $content = $cache->get($url) ) { if ( $content eq 'y' ) { $promise->resolve; return $promise; } elsif ( $content eq 'n' ) { $promise->reject; return $promise; } } $self->ua->request_timeout(5)->head_p($url)->then( sub { my ($tx) = @_; if ( $tx->result->is_success ) { $cache->set( $url, 'y' ); $promise->resolve; } else { $cache->set( $url, 'n' ); $promise->reject; } } )->catch( sub { $cache->set( $url, 'n' ); $promise->reject; } )->wait; return $promise; } ); $self->helper( 'get_wagonorder_p' => sub { my ( $self, $ts, $train_no ) = @_; my $api_ts = $ts->strftime('%Y%m%d%H%M'); my $url = "https://www.apps-bahn.de/wr/wagenreihung/1.0/${train_no}/${api_ts}"; my $cache = $self->app->cache_iris_main; my $promise = Mojo::Promise->new; if ( my $content = $cache->thaw($url) ) { $promise->resolve($content); return $promise; } $self->ua->request_timeout(5)->get_p($url)->then( sub { my ($tx) = @_; my $body = decode( 'utf-8', $tx->res->body ); my $json = JSON->new->decode($body); $cache->freeze( $url, $json ); $promise->resolve($json); } )->catch( sub { my ($err) = @_; $promise->reject($err); } )->wait; return $promise; } ); $self->helper( 'get_hafas_polyline_p' => sub { my ( $self, $train, $trip_id ) = @_; my $line = $train->line // 0; my $url = "https://2.db.transport.rest/trips/${trip_id}?lineName=${line}&polyline=true"; my $cache = $self->app->cache_iris_main; my $promise = Mojo::Promise->new; my $version = $self->app->config->{version}; if ( my $content = $cache->thaw($url) ) { $promise->resolve($content); return $promise; } $self->ua->request_timeout(5)->get_p( $url => { 'User-Agent' => "travelynx/${version} +https://finalrewind.org/projects/travelynx" } )->then( sub { my ($tx) = @_; my $body = decode( 'utf-8', $tx->res->body ); my $json = JSON->new->decode($body); my @station_list; my @coordinate_list; for my $feature ( @{ $json->{polyline}{features} } ) { if ( exists $feature->{geometry}{coordinates} ) { my $coord = $feature->{geometry}{coordinates}; if ( exists $feature->{properties}{type} and $feature->{properties}{type} eq 'stop' ) { push( @{$coord}, $feature->{properties}{id} ); push( @station_list, $feature->{properties}{name} ); } push( @coordinate_list, $coord ); } } my $ret = { name => $json->{line}{name} // '?', polyline => [@coordinate_list], raw => $json, }; $cache->freeze( $url, $ret ); # borders ("(Gr)" as in "Grenze") are only returned by HAFAS. # They are not stations. my $iris_stations = join( '|', $train->route ); my $hafas_stations = join( '|', grep { $_ !~ m{\(Gr\)$} } @station_list ); # Do not return polyline if it belongs to an entirely different # train. Trains with longer routes (e.g. due to train number # changes, which are handled by HAFAS but left out in IRIS) # are okay though. if ( $iris_stations ne $hafas_stations and index( $hafas_stations, $iris_stations ) == -1 ) { $self->app->log->warn( 'Ignoring polyline for ' . $train->line . ": IRIS route does not agree with HAFAS route: $iris_stations != $hafas_stations" ); $promise->reject('polyline route mismatch'); } else { $promise->resolve($ret); } } )->catch( sub { my ($err) = @_; $promise->reject($err); } )->wait; return $promise; } ); $self->helper( 'get_hafas_tripid_p' => sub { my ( $self, $train ) = @_; my $promise = Mojo::Promise->new; my $cache = $self->app->cache_iris_main; my $eva = $train->station_uic; my $dep_ts = DateTime->now( time_zone => 'Europe/Berlin' ); my $url = "https://2.db.transport.rest/stations/${eva}/departures?duration=5&when=$dep_ts"; if ( $train->sched_departure ) { $dep_ts = $train->sched_departure->epoch; $url = "https://2.db.transport.rest/stations/${eva}/departures?duration=5&when=$dep_ts"; } elsif ( $train->sched_arrival ) { $dep_ts = $train->sched_arrival->epoch; $url = "https://2.db.transport.rest/stations/${eva}/arrivals?duration=5&when=$dep_ts"; } $self->get_hafas_rest_p($url)->then( sub { my ($json) = @_; for my $result ( @{$json} ) { if ( $result->{line} and $result->{line}{fahrtNr} == $train->train_no ) { my $trip_id = $result->{tripId}; $promise->resolve($trip_id); return; } } $promise->reject; } )->catch( sub { my ($err) = @_; $promise->reject($err); } )->wait; return $promise; } ); $self->helper( 'get_hafas_rest_p' => sub { my ( $self, $url ) = @_; my $cache = $self->app->cache_iris_main; my $promise = Mojo::Promise->new; if ( my $content = $cache->thaw($url) ) { $promise->resolve($content); return $promise; } $self->ua->request_timeout(5)->get_p($url)->then( sub { my ($tx) = @_; my $json = JSON->new->decode( $tx->res->body ); $cache->freeze( $url, $json ); $promise->resolve($json); } )->catch( sub { my ($err) = @_; $self->app->log->warn("get($url): $err"); $promise->reject($err); } )->wait; return $promise; } ); $self->helper( 'get_hafas_json_p' => sub { my ( $self, $url ) = @_; my $cache = $self->app->cache_iris_main; my $promise = Mojo::Promise->new; if ( my $content = $cache->thaw($url) ) { $promise->resolve($content); return $promise; } $self->ua->request_timeout(5)->get_p($url)->then( sub { my ($tx) = @_; my $body = decode( 'ISO-8859-15', $tx->res->body ); $body =~ s{^TSLs[.]sls = }{}; $body =~ s{;$}{}; $body =~ s{(}{(}g; $body =~ s{)}{)}g; my $json = JSON->new->decode($body); $cache->freeze( $url, $json ); $promise->resolve($json); } )->catch( sub { my ($err) = @_; $self->app->log->warn("get($url): $err"); $promise->reject($err); } )->wait; return $promise; } ); $self->helper( 'get_hafas_xml_p' => sub { my ( $self, $url ) = @_; my $cache = $self->app->cache_iris_rt; my $promise = Mojo::Promise->new; if ( my $content = $cache->thaw($url) ) { $promise->resolve($content); return $promise; } $self->ua->request_timeout(5)->get_p($url)->then( sub { my ($tx) = @_; my $body = decode( 'ISO-8859-15', $tx->res->body ); my $tree; my $traininfo = { station => {}, messages => [], }; # is invalid HTML, but present in # regardless. As it is the last tag, we just throw it away. $body =~ s{]*/>}{}s; # More fixes for invalid XML $body =~ s{P&R}{P&R}; eval { $tree = XML::LibXML->load_xml( string => $body ) }; if ($@) { $self->app->log->warn("load_xml($url): $@"); $cache->freeze( $url, $traininfo ); $promise->resolve($traininfo); return; } for my $station ( $tree->findnodes('/Journey/St') ) { my $name = $station->getAttribute('name'); my $adelay = $station->getAttribute('adelay'); my $ddelay = $station->getAttribute('ddelay'); $traininfo->{station}{$name} = { adelay => $adelay, ddelay => $ddelay, }; } for my $message ( $tree->findnodes('/Journey/HIMMessage') ) { my $header = $message->getAttribute('header'); my $lead = $message->getAttribute('lead'); my $display = $message->getAttribute('display'); push( @{ $traininfo->{messages} }, { header => $header, lead => $lead, display => $display } ); } $cache->freeze( $url, $traininfo ); $promise->resolve($traininfo); } )->catch( sub { my ($err) = @_; $self->app->log->warn("get($url): $err"); $promise->reject($err); } )->wait; return $promise; } ); $self->helper( 'add_route_timestamps' => sub { my ( $self, $uid, $train, $is_departure ) = @_; $uid //= $self->current_user->{id}; my $db = $self->pg->db; my $journey = $db->select( 'in_transit_str', [ 'arr_eva', 'dep_eva', 'route', 'data' ], { user_id => $uid } )->expand->hash; if ( not $journey ) { return; } if ( not $journey->{data}{trip_id} ) { my ( $origin_eva, $destination_eva, $polyline_str ); $self->get_hafas_tripid_p($train)->then( sub { my ($trip_id) = @_; my $res = $db->select( 'in_transit', ['data'], { user_id => $uid } ); my $res_h = $res->expand->hash; my $data = $res_h->{data} // {}; $data->{trip_id} = $trip_id; $db->update( 'in_transit', { data => JSON->new->encode($data) }, { user_id => $uid } ); return $self->get_hafas_polyline_p( $train, $trip_id ); } )->then( sub { my ($ret) = @_; my $polyline = $ret->{polyline}; $origin_eva = 0 + $ret->{raw}{origin}{id}; $destination_eva = 0 + $ret->{raw}{destination}{id}; # work around Cache::File turning floats into strings for my $coord ( @{$polyline} ) { @{$coord} = map { 0 + $_ } @{$coord}; } $polyline_str = JSON->new->encode($polyline); return $db->select_p( 'polylines', ['id'], { origin_eva => $origin_eva, destination_eva => $destination_eva, polyline => $polyline_str }, { limit => 1 } ); } )->then( sub { my ($pl_res) = @_; my $polyline_id; if ( my $h = $pl_res->hash ) { $polyline_id = $h->{id}; } else { eval { $polyline_id = $db->insert( 'polylines', { origin_eva => $origin_eva, destination_eva => $destination_eva, polyline => $polyline_str }, { returning => 'id' } )->hash->{id}; }; if ($@) { $self->app->log->warn( "add_route_timestamps: insert polyline: $@" ); } } if ($polyline_id) { $db->update( 'in_transit', { polyline_id => $polyline_id }, { user_id => $uid } ); } } )->wait; } my ($platform) = ( ( $train->platform // 0 ) =~ m{(\d+)} ); my $route = $journey->{route}; my $base = 'https://reiseauskunft.bahn.de/bin/trainsearch.exe/dn?L=vs_json.vs_hap&start=yes&rt=1'; my $date_yy = $train->start->strftime('%d.%m.%y'); my $date_yyyy = $train->start->strftime('%d.%m.%Y'); my $train_no = $train->type . ' ' . $train->train_no; my ( $trainlink, $route_data ); $self->get_hafas_json_p( "${base}&date=${date_yy}&trainname=${train_no}")->then( sub { my ($trainsearch) = @_; # Fallback: Take first result $trainlink = $trainsearch->{suggestions}[0]{trainLink}; # Try finding a result for the current date for my $suggestion ( @{ $trainsearch->{suggestions} // [] } ) { # Drunken API, sail with care. Both date formats are used interchangeably if ( $suggestion->{depDate} and ( $suggestion->{depDate} eq $date_yy or $suggestion->{depDate} eq $date_yyyy ) ) { # Train numbers are not unique, e.g. IC 149 refers both to the # InterCity service Amsterdam -> Berlin and to the InterCity service # Koebenhavns Lufthavn st -> Aarhus. One workaround is making # requests with the stationFilter=80 parameter. Checking the origin # station seems to be the more generic solution, so we do that # instead. if ( $suggestion->{dep} eq $train->origin ) { $trainlink = $suggestion->{trainLink}; last; } } } if ( not $trainlink ) { $self->app->log->debug("trainlink not found"); return Mojo::Promise->reject("trainlink not found"); } my $base2 = 'https://reiseauskunft.bahn.de/bin/traininfo.exe/dn'; return $self->get_hafas_json_p( "${base2}/${trainlink}?rt=1&date=${date_yy}&L=vs_json.vs_hap" ); } )->then( sub { my ($traininfo) = @_; if ( not $traininfo or $traininfo->{error} ) { $self->app->log->debug("traininfo error"); return Mojo::Promise->reject("traininfo error"); } my $routeinfo = $traininfo->{suggestions}[0]{locations}; my $strp = DateTime::Format::Strptime->new( pattern => '%d.%m.%y %H:%M', time_zone => 'Europe/Berlin', ); $route_data = {}; for my $station ( @{$routeinfo} ) { my $arr = $strp->parse_datetime( $station->{arrDate} . ' ' . $station->{arrTime} ); my $dep = $strp->parse_datetime( $station->{depDate} . ' ' . $station->{depTime} ); $route_data->{ $station->{name} } = { sched_arr => $arr ? $arr->epoch : 0, sched_dep => $dep ? $dep->epoch : 0, }; } my $base2 = 'https://reiseauskunft.bahn.de/bin/traininfo.exe/dn'; return $self->get_hafas_xml_p( "${base2}/${trainlink}?rt=1&date=${date_yy}&L=vs_java3" ); } )->then( sub { my ($traininfo2) = @_; for my $station ( keys %{$route_data} ) { for my $key ( keys %{ $traininfo2->{station}{$station} // {} } ) { $route_data->{$station}{$key} = $traininfo2->{station}{$station}{$key}; } } for my $station ( @{$route} ) { $station->[1] = $route_data->{ $station->[0] }; } my $res = $db->select( 'in_transit', ['data'], { user_id => $uid } ); my $res_h = $res->expand->hash; my $data = $res_h->{data} // {}; $data->{delay_msg} = [ map { [ $_->[0]->epoch, $_->[1] ] } $train->delay_messages ]; $data->{qos_msg} = [ map { [ $_->[0]->epoch, $_->[1] ] } $train->qos_messages ]; $data->{him_msg} = $traininfo2->{messages}; $db->update( 'in_transit', { route => JSON->new->encode($route), data => JSON->new->encode($data) }, { user_id => $uid } ); } )->wait; if ( $train->sched_departure ) { $self->has_wagonorder_p( $train->sched_departure, $train->train_no )->then( sub { return $self->get_wagonorder_p( $train->sched_departure, $train->train_no ); } )->then( sub { my ($wagonorder) = @_; my $res = $db->select( 'in_transit', [ 'data', 'user_data' ], { user_id => $uid } ); my $res_h = $res->expand->hash; my $data = $res_h->{data} // {}; my $user_data = $res_h->{user_data} // {}; if ( $is_departure and not exists $wagonorder->{error} ) { $data->{wagonorder_dep} = $wagonorder; if ( exists $user_data->{wagongroups} ) { $user_data->{wagongroups} = []; } for my $group ( @{ $wagonorder->{data}{istformation} {allFahrzeuggruppe} // [] } ) { my @wagons; for my $wagon ( @{ $group->{allFahrzeug} // [] } ) { push( @wagons, { id => $wagon->{fahrzeugnummer}, number => $wagon->{wagenordnungsnummer}, type => $wagon->{fahrzeugtyp}, } ); } push( @{ $user_data->{wagongroups} }, { name => $group->{fahrzeuggruppebezeichnung}, from => $group->{startbetriebsstellename}, to => $group->{zielbetriebsstellename}, no => $group->{verkehrlichezugnummer}, wagons => [@wagons], } ); } $db->update( 'in_transit', { data => JSON->new->encode($data), user_data => JSON->new->encode($user_data) }, { user_id => $uid } ); } elsif ( not $is_departure and not exists $wagonorder->{error} ) { $data->{wagonorder_arr} = $wagonorder; $db->update( 'in_transit', { data => JSON->new->encode($data) }, { user_id => $uid } ); } } )->wait; } if ($is_departure) { $self->get_dbdb_station_p( $journey->{dep_eva} )->then( sub { my ($station_info) = @_; my $res = $db->select( 'in_transit', ['data'], { user_id => $uid } ); my $res_h = $res->expand->hash; my $data = $res_h->{data} // {}; $data->{stationinfo_dep} = $station_info; $db->update( 'in_transit', { data => JSON->new->encode($data) }, { user_id => $uid } ); } )->wait; } if ( $journey->{arr_eva} and not $is_departure ) { $self->get_dbdb_station_p( $journey->{arr_eva} )->then( sub { my ($station_info) = @_; my $res = $db->select( 'in_transit', ['data'], { user_id => $uid } ); my $res_h = $res->expand->hash; my $data = $res_h->{data} // {}; $data->{stationinfo_arr} = $station_info; $db->update( 'in_transit', { data => JSON->new->encode($data) }, { user_id => $uid } ); } )->wait; } } ); $self->helper( 'get_oldest_journey_ts' => sub { my ($self) = @_; my $res_h = $self->pg->db->select( 'journeys_str', ['sched_dep_ts'], { user_id => $self->current_user->{id}, }, { limit => 1, order_by => { -asc => 'real_dep_ts', }, } )->hash; if ($res_h) { return epoch_to_dt( $res_h->{sched_dep_ts} ); } return undef; } ); $self->helper( 'get_latest_dest_id' => sub { my ( $self, %opt ) = @_; my $uid = $opt{uid} // $self->current_user->{id}; my $db = $opt{db} // $self->pg->db; my $journey = $db->select( 'in_transit', ['checkout_station_id'], { user_id => $uid } )->hash; if ( not $journey ) { $journey = $db->select( 'journeys', ['checkout_station_id'], { user_id => $uid, cancelled => 0 }, { limit => 1, order_by => { -desc => 'real_departure' } } )->hash; } if ( not $journey ) { return; } return $journey->{checkout_station_id}; } ); $self->helper( 'get_connection_targets' => sub { my ( $self, %opt ) = @_; my $uid = $opt{uid} //= $self->current_user->{id}; my $threshold = $opt{threshold} // DateTime->now( time_zone => 'Europe/Berlin' ) ->subtract( months => 4 ); my $db = $opt{db} //= $self->pg->db; my $min_count = $opt{min_count} // 3; if ( $opt{destination_name} ) { return ( $opt{destination_name} ); } my $dest_id = $opt{eva} // $self->get_latest_dest_id(%opt); if ( not $dest_id ) { return; } my $res = $db->query( qq{ select count(checkout_station_id) as count, checkout_station_id as dest from journeys where user_id = ? and checkin_station_id = ? and real_departure > ? group by checkout_station_id order by count desc; }, $uid, $dest_id, $threshold ); my @destinations = $res->hashes->grep( sub { shift->{count} >= $min_count } ) ->map( sub { shift->{dest} } )->each; @destinations = grep { $self->app->station_by_eva->{$_} } @destinations; @destinations = map { $self->app->station_by_eva->{$_}->[1] } @destinations; return @destinations; } ); $self->helper( 'get_connecting_trains' => sub { my ( $self, %opt ) = @_; my $uid = $opt{uid} //= $self->current_user->{id}; my $use_history = $self->account_use_history($uid); my ( $eva, $exclude_via, $exclude_train_id, $exclude_before ); my $now = $self->now->epoch; if ( $opt{eva} ) { if ( $use_history & 0x01 ) { $eva = $opt{eva}; } elsif ( $opt{destination_name} ) { $eva = $opt{eva}; } } else { if ( $use_history & 0x02 ) { my $status = $self->get_user_status; $eva = $status->{arr_eva}; $exclude_via = $status->{dep_name}; $exclude_train_id = $status->{train_id}; if ( $status->{real_arrival} ) { $exclude_before = $status->{real_arrival}->epoch; } } } $exclude_before //= $now - 300; if ( not $eva ) { return; } my @destinations = $self->get_connection_targets(%opt); if ($exclude_via) { @destinations = grep { $_ ne $exclude_via } @destinations; } if ( not @destinations ) { return; } my $stationboard = $self->get_departures( $eva, 10, 40, 1 ); if ( $stationboard->{errstr} ) { return; } @{ $stationboard->{results} } = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->departure ? $_->departure->epoch : 0 ] } @{ $stationboard->{results} }; my @results; my @cancellations; my %via_count = map { $_ => 0 } @destinations; for my $train ( @{ $stationboard->{results} } ) { if ( not $train->departure ) { next; } if ( $exclude_before and $train->departure and $train->departure->epoch < $exclude_before ) { next; } if ( $exclude_train_id and $train->train_id eq $exclude_train_id ) { next; } # In general, this function is meant to return feasible # connections. However, cancelled connections may also be of # interest and are also useful for logging cancellations. # To satisfy both demands with (hopefully) little confusion and # UI clutter, this function returns two concatenated arrays: # actual connections (ordered by actual departure time) followed # by cancelled connections (ordered by scheduled departure time). # This is easiest to achieve in two separate loops. # # Note that a cancelled train may still have a matching destination # in its route_post, e.g. if it leaves out $eva due to # unscheduled route changes but continues on schedule afterwards # -- so it is only cancelled at $eva, not on the remainder of # the route. Also note that this specific case is not yet handled # properly by the cancellation logic etc. if ( $train->departure_is_cancelled ) { my @via = ( $train->sched_route_post, $train->sched_route_end ); for my $dest (@destinations) { if ( List::Util::any { $_ eq $dest } @via ) { push( @cancellations, [ $train, $dest ] ); next; } } } else { my @via = ( $train->route_post, $train->route_end ); for my $dest (@destinations) { if ( $via_count{$dest} < 2 and List::Util::any { $_ eq $dest } @via ) { push( @results, [ $train, $dest ] ); # Show all past and up to two future departures per destination if ( not $train->departure or $train->departure->epoch >= $now ) { $via_count{$dest}++; } next; } } } } @results = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->[0]->departure->epoch // $_->[0]->sched_departure->epoch ] } @results; @cancellations = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->[0]->sched_departure->epoch ] } @cancellations; for my $result (@results) { my $train = $result->[0]; my @message_ids = List::Util::uniq map { $_->[1] } $train->raw_messages; $train->{message_id} = { map { $_ => 1 } @message_ids }; } return ( @results, @cancellations ); } ); $self->helper( 'account_use_history' => sub { my ( $self, $uid, $value ) = @_; if ($value) { $self->pg->db->update( 'users', { use_history => $value }, { id => $uid } ); } else { return $self->pg->db->select( 'users', ['use_history'], { id => $uid } )->hash->{use_history}; } } ); $self->helper( 'get_user_travels' => sub { my ( $self, %opt ) = @_; my $uid = $opt{uid} || $self->current_user->{id}; # If get_user_travels is called from inside a transaction, db # specifies the database handle performing the transaction. # Otherwise, we grab a fresh one. my $db = $opt{db} // $self->pg->db; my @select = ( qw(journey_id train_type train_line train_no checkin_ts sched_dep_ts real_dep_ts dep_eva checkout_ts sched_arr_ts real_arr_ts arr_eva cancelled edited route messages user_data) ); my %where = ( user_id => $uid, cancelled => 0 ); my %order = ( order_by => { -desc => 'real_dep_ts', } ); if ( $opt{cancelled} ) { $where{cancelled} = 1; } if ( $opt{limit} ) { $order{limit} = $opt{limit}; } if ( $opt{journey_id} ) { $where{journey_id} = $opt{journey_id}; delete $where{cancelled}; } elsif ( $opt{after} and $opt{before} ) { $where{real_dep_ts} = { -between => [ $opt{after}->epoch, $opt{before}->epoch, ] }; } if ( $opt{with_polyline} ) { push( @select, 'polyline' ); } my @travels; my $res = $db->select( 'journeys_str', \@select, \%where, \%order ); for my $entry ( $res->expand->hashes->each ) { my $ref = { id => $entry->{journey_id}, type => $entry->{train_type}, line => $entry->{train_line}, no => $entry->{train_no}, from_eva => $entry->{dep_eva}, checkin_ts => $entry->{checkin_ts}, sched_dep_ts => $entry->{sched_dep_ts}, rt_dep_ts => $entry->{real_dep_ts}, to_eva => $entry->{arr_eva}, checkout_ts => $entry->{checkout_ts}, sched_arr_ts => $entry->{sched_arr_ts}, rt_arr_ts => $entry->{real_arr_ts}, messages => $entry->{messages}, route => $entry->{route}, edited => $entry->{edited}, user_data => $entry->{user_data}, }; if ( $opt{with_polyline} ) { $ref->{polyline} = $entry->{polyline}; } if ( my $station = $self->app->station_by_eva->{ $ref->{from_eva} } ) { $ref->{from_ds100} = $station->[0]; $ref->{from_name} = $station->[1]; } if ( my $station = $self->app->station_by_eva->{ $ref->{to_eva} } ) { $ref->{to_ds100} = $station->[0]; $ref->{to_name} = $station->[1]; } if ( $opt{with_datetime} ) { $ref->{checkin} = epoch_to_dt( $ref->{checkin_ts} ); $ref->{sched_departure} = epoch_to_dt( $ref->{sched_dep_ts} ); $ref->{rt_departure} = epoch_to_dt( $ref->{rt_dep_ts} ); $ref->{checkout} = epoch_to_dt( $ref->{checkout_ts} ); $ref->{sched_arrival} = epoch_to_dt( $ref->{sched_arr_ts} ); $ref->{rt_arrival} = epoch_to_dt( $ref->{rt_arr_ts} ); } if ( $opt{verbose} ) { my $rename = $self->app->renamed_station; for my $stop ( @{ $ref->{route} } ) { if ( $rename->{ $stop->[0] } ) { $stop->[0] = $rename->{ $stop->[0] }; } } $ref->{cancelled} = $entry->{cancelled}; my @parsed_messages; for my $message ( @{ $ref->{messages} // [] } ) { my ( $ts, $msg ) = @{$message}; push( @parsed_messages, [ epoch_to_dt($ts), $msg ] ); } $ref->{messages} = [ reverse @parsed_messages ]; $ref->{sched_duration} = defined $ref->{sched_arr_ts} ? $ref->{sched_arr_ts} - $ref->{sched_dep_ts} : undef; $ref->{rt_duration} = defined $ref->{rt_arr_ts} ? $ref->{rt_arr_ts} - $ref->{rt_dep_ts} : undef; my ( $km_polyline, $km_route, $km_beeline, $skip ) = $self->get_travel_distance($ref); $ref->{km_route} = $km_polyline || $km_route; $ref->{skip_route} = $km_polyline ? 0 : $skip; $ref->{km_beeline} = $km_beeline; $ref->{skip_beeline} = $skip; my $kmh_divisor = ( $ref->{rt_duration} // $ref->{sched_duration} // 999999 ) / 3600; $ref->{kmh_route} = $kmh_divisor ? $ref->{km_route} / $kmh_divisor : -1; $ref->{kmh_beeline} = $kmh_divisor ? $ref->{km_beeline} / $kmh_divisor : -1; } push( @travels, $ref ); } return @travels; } ); $self->helper( 'get_journey' => sub { my ( $self, %opt ) = @_; $opt{cancelled} = 'any'; my @journeys = $self->get_user_travels(%opt); if ( @journeys == 0 ) { return undef; } return $journeys[0]; } ); $self->helper( 'stationinfo_to_direction' => sub { my ( $self, $platform_info, $wagonorder, $prev_stop, $next_stop ) = @_; if ( $platform_info->{kopfgleis} ) { if ($next_stop) { return $platform_info->{direction} eq 'r' ? 'l' : 'r'; } return $platform_info->{direction}; } elsif ( $prev_stop and exists $platform_info->{direction_from}{$prev_stop} ) { return $platform_info->{direction_from}{$prev_stop}; } elsif ( $next_stop and exists $platform_info->{direction_from}{$next_stop} ) { return $platform_info->{direction_from}{$next_stop} eq 'r' ? 'l' : 'r'; } elsif ($wagonorder) { my $wr; eval { $wr = Travel::Status::DE::DBWagenreihung->new( from_json => $wagonorder ); }; if ( $wr and $wr->sections and defined $wr->direction ) { my $section_0 = ( $wr->sections )[0]; my $direction = $wr->direction; if ( $section_0->name eq 'A' and $direction == 0 ) { return $platform_info->{direction}; } elsif ( $section_0->name ne 'A' and $direction == 100 ) { return $platform_info->{direction}; } elsif ( $platform_info->{direction} ) { return $platform_info->{direction} eq 'r' ? 'l' : 'r'; } return; } } } ); $self->helper( 'journey_to_ajax_route' => sub { my ( $self, $journey ) = @_; my @route; for my $station ( @{ $journey->{route_after} } ) { my $station_desc = $station->[0]; if ( $station->[1]{rt_arr} ) { $station_desc .= $station->[1]{sched_arr}->strftime(';%s'); $station_desc .= $station->[1]{rt_arr}->strftime(';%s'); if ( $station->[1]{rt_dep} ) { $station_desc .= $station->[1]{sched_dep}->strftime(';%s'); $station_desc .= $station->[1]{rt_dep}->strftime(';%s'); } else { $station_desc .= ';0;0'; } } else { $station_desc .= ';0;0;0;0'; } push( @route, $station_desc ); } return join( '|', @route ); } ); $self->helper( 'get_user_status' => sub { my ( $self, $uid ) = @_; $uid //= $self->current_user->{id}; my $db = $self->pg->db; my $now = DateTime->now( time_zone => 'Europe/Berlin' ); my $epoch = $now->epoch; my $in_transit = $db->select( 'in_transit_str', '*', { user_id => $uid } ) ->expand->hash; if ($in_transit) { if ( my $station = $self->app->station_by_eva->{ $in_transit->{dep_eva} } ) { $in_transit->{dep_ds100} = $station->[0]; $in_transit->{dep_name} = $station->[1]; } if ( $in_transit->{arr_eva} and my $station = $self->app->station_by_eva->{ $in_transit->{arr_eva} } ) { $in_transit->{arr_ds100} = $station->[0]; $in_transit->{arr_name} = $station->[1]; } my @route = @{ $in_transit->{route} // [] }; my @route_after; my $dep_info; my $stop_before_dest; my $is_after = 0; for my $station (@route) { if ( $in_transit->{arr_name} and @route_after and $station->[0] eq $in_transit->{arr_name} ) { $stop_before_dest = $route_after[-1][0]; } if ($is_after) { push( @route_after, $station ); } if ( $in_transit->{dep_name} and $station->[0] eq $in_transit->{dep_name} ) { $is_after = 1; if ( @{$station} > 1 ) { $dep_info = $station->[1]; } } } my $stop_after_dep = @route_after ? $route_after[0][0] : undef; my $ts = $in_transit->{checkout_ts} // $in_transit->{checkin_ts}; my $action_time = epoch_to_dt($ts); my $ret = { checked_in => !$in_transit->{cancelled}, cancelled => $in_transit->{cancelled}, timestamp => $action_time, timestamp_delta => $now->epoch - $action_time->epoch, train_type => $in_transit->{train_type}, train_line => $in_transit->{train_line}, train_no => $in_transit->{train_no}, train_id => $in_transit->{train_id}, boarding_countdown => -1, sched_departure => epoch_to_dt( $in_transit->{sched_dep_ts} ), real_departure => epoch_to_dt( $in_transit->{real_dep_ts} ), dep_ds100 => $in_transit->{dep_ds100}, dep_eva => $in_transit->{dep_eva}, dep_name => $in_transit->{dep_name}, dep_platform => $in_transit->{dep_platform}, sched_arrival => epoch_to_dt( $in_transit->{sched_arr_ts} ), real_arrival => epoch_to_dt( $in_transit->{real_arr_ts} ), arr_ds100 => $in_transit->{arr_ds100}, arr_eva => $in_transit->{arr_eva}, arr_name => $in_transit->{arr_name}, arr_platform => $in_transit->{arr_platform}, route_after => \@route_after, messages => $in_transit->{messages}, extra_data => $in_transit->{data}, comment => $in_transit->{user_data}{comment}, }; my @parsed_messages; for my $message ( @{ $ret->{messages} // [] } ) { my ( $ts, $msg ) = @{$message}; push( @parsed_messages, [ epoch_to_dt($ts), $msg ] ); } $ret->{messages} = [ reverse @parsed_messages ]; @parsed_messages = (); for my $message ( @{ $ret->{extra_data}{qos_msg} // [] } ) { my ( $ts, $msg ) = @{$message}; push( @parsed_messages, [ epoch_to_dt($ts), $msg ] ); } $ret->{extra_data}{qos_msg} = [@parsed_messages]; if ( $dep_info and $dep_info->{sched_arr} ) { $dep_info->{sched_arr} = epoch_to_dt( $dep_info->{sched_arr} ); $dep_info->{rt_arr} = $dep_info->{sched_arr}->clone; if ( $dep_info->{adelay} and $dep_info->{adelay} =~ m{^\d+$} ) { $dep_info->{rt_arr} ->add( minutes => $dep_info->{adelay} ); } $dep_info->{rt_arr_countdown} = $ret->{boarding_countdown} = $dep_info->{rt_arr}->epoch - $epoch; } for my $station (@route_after) { if ( @{$station} > 1 ) { # Note: $station->[1]{sched_arr} may already have been # converted to a DateTime object in $station->[1] is # $dep_info. This can happen when a station is present # several times in a train's route, e.g. for Frankfurt # Flughafen in some nightly connections. my $times = $station->[1]; if ( $times->{sched_arr} and ref( $times->{sched_arr} ) ne 'DateTime' ) { $times->{sched_arr} = epoch_to_dt( $times->{sched_arr} ); $times->{rt_arr} = $times->{sched_arr}->clone; if ( $times->{adelay} and $times->{adelay} =~ m{^\d+$} ) { $times->{rt_arr} ->add( minutes => $times->{adelay} ); } $times->{rt_arr_countdown} = $times->{rt_arr}->epoch - $epoch; } if ( $times->{sched_dep} and ref( $times->{sched_dep} ) ne 'DateTime' ) { $times->{sched_dep} = epoch_to_dt( $times->{sched_dep} ); $times->{rt_dep} = $times->{sched_dep}->clone; if ( $times->{ddelay} and $times->{ddelay} =~ m{^\d+$} ) { $times->{rt_dep} ->add( minutes => $times->{ddelay} ); } $times->{rt_dep_countdown} = $times->{rt_dep}->epoch - $epoch; } } } $ret->{departure_countdown} = $ret->{real_departure}->epoch - $now->epoch; if ( $ret->{departure_countdown} > 0 and $in_transit->{data}{wagonorder_dep} ) { my $wr; eval { $wr = Travel::Status::DE::DBWagenreihung->new( from_json => $in_transit->{data}{wagonorder_dep} ); }; if ( $wr and $wr->sections and $wr->wagons and defined $wr->direction ) { $ret->{wagonorder} = $wr; } } if ( $in_transit->{real_arr_ts} ) { $ret->{arrival_countdown} = $ret->{real_arrival}->epoch - $now->epoch; $ret->{journey_duration} = $ret->{real_arrival}->epoch - $ret->{real_departure}->epoch; $ret->{journey_completion} = $ret->{journey_duration} ? 1 - ( $ret->{arrival_countdown} / $ret->{journey_duration} ) : 1; if ( $ret->{journey_completion} > 1 ) { $ret->{journey_completion} = 1; } elsif ( $ret->{journey_completion} < 0 ) { $ret->{journey_completion} = 0; } my ($dep_platform_number) = ( ( $ret->{dep_platform} // 0 ) =~ m{(\d+)} ); if ( $dep_platform_number and exists $in_transit->{data}{stationinfo_dep} {$dep_platform_number} ) { $ret->{dep_direction} = $self->stationinfo_to_direction( $in_transit->{data}{stationinfo_dep} {$dep_platform_number}, $in_transit->{data}{wagonorder_dep}, undef, $stop_after_dep ); } my ($arr_platform_number) = ( ( $ret->{arr_platform} // 0 ) =~ m{(\d+)} ); if ( $arr_platform_number and exists $in_transit->{data}{stationinfo_arr} {$arr_platform_number} ) { $ret->{arr_direction} = $self->stationinfo_to_direction( $in_transit->{data}{stationinfo_arr} {$arr_platform_number}, $in_transit->{data}{wagonorder_arr}, $stop_before_dest, undef ); } } else { $ret->{arrival_countdown} = undef; $ret->{journey_duration} = undef; $ret->{journey_completion} = undef; } return $ret; } my $latest = $db->select( 'journeys_str', '*', { user_id => $uid, cancelled => 0 }, { order_by => { -desc => 'journey_id' }, limit => 1 } )->expand->hash; my $latest_cancellation = $db->select( 'journeys_str', '*', { user_id => $uid, }, { order_by => { -desc => 'journey_id' }, limit => 1 } )->expand->hash; if ( $latest_cancellation and $latest_cancellation->{cancelled} ) { if ( my $station = $self->app->station_by_eva ->{ $latest_cancellation->{dep_eva} } ) { $latest_cancellation->{dep_ds100} = $station->[0]; $latest_cancellation->{dep_name} = $station->[1]; } if ( my $station = $self->app->station_by_eva ->{ $latest_cancellation->{arr_eva} } ) { $latest_cancellation->{arr_ds100} = $station->[0]; $latest_cancellation->{arr_name} = $station->[1]; } } else { $latest_cancellation = undef; } if ($latest) { my $ts = $latest->{checkout_ts}; my $action_time = epoch_to_dt($ts); if ( my $station = $self->app->station_by_eva->{ $latest->{dep_eva} } ) { $latest->{dep_ds100} = $station->[0]; $latest->{dep_name} = $station->[1]; } if ( my $station = $self->app->station_by_eva->{ $latest->{arr_eva} } ) { $latest->{arr_ds100} = $station->[0]; $latest->{arr_name} = $station->[1]; } return { checked_in => 0, cancelled => 0, cancellation => $latest_cancellation, journey_id => $latest->{journey_id}, timestamp => $action_time, timestamp_delta => $now->epoch - $action_time->epoch, train_type => $latest->{train_type}, train_line => $latest->{train_line}, train_no => $latest->{train_no}, train_id => $latest->{train_id}, sched_departure => epoch_to_dt( $latest->{sched_dep_ts} ), real_departure => epoch_to_dt( $latest->{real_dep_ts} ), dep_ds100 => $latest->{dep_ds100}, dep_eva => $latest->{dep_eva}, dep_name => $latest->{dep_name}, dep_platform => $latest->{dep_platform}, sched_arrival => epoch_to_dt( $latest->{sched_arr_ts} ), real_arrival => epoch_to_dt( $latest->{real_arr_ts} ), arr_ds100 => $latest->{arr_ds100}, arr_eva => $latest->{arr_eva}, arr_name => $latest->{arr_name}, arr_platform => $latest->{arr_platform}, comment => $latest->{user_data}{comment}, }; } return { checked_in => 0, cancelled => 0, cancellation => $latest_cancellation, no_journeys_yet => 1, timestamp => epoch_to_dt(0), timestamp_delta => $now->epoch, }; } ); $self->helper( 'get_user_status_json_v1' => sub { my ( $self, $uid ) = @_; my $status = $self->get_user_status($uid); # TODO simplify lon/lat (can be returned from get_user_status) my $ret = { deprecated => \0, checkedIn => ( $status->{checked_in} or $status->{cancelled} ) ? \1 : \0, fromStation => { ds100 => $status->{dep_ds100}, name => $status->{dep_name}, uic => $status->{dep_eva}, longitude => undef, latitude => undef, scheduledTime => $status->{sched_departure} ? $status->{sched_departure}->epoch : undef, realTime => $status->{real_departure} ? $status->{real_departure}->epoch : undef, }, toStation => { ds100 => $status->{arr_ds100}, name => $status->{arr_name}, uic => $status->{arr_eva}, longitude => undef, latitude => undef, scheduledTime => $status->{sched_arrival} ? $status->{sched_arrival}->epoch : undef, realTime => $status->{real_arrival} ? $status->{real_arrival}->epoch : undef, }, train => { type => $status->{train_type}, line => $status->{train_line}, no => $status->{train_no}, id => $status->{train_id}, }, actionTime => $status->{timestamp} ? $status->{timestamp}->epoch : undef, intermediateStops => [], }; for my $stop ( @{ $status->{route_after} // [] } ) { if ( $status->{arr_name} and $stop->[0] eq $status->{arr_name} ) { last; } push( @{ $ret->{intermediateStops} }, { name => $stop->[0], scheduledArrival => $stop->[1]{sched_arr} ? $stop->[1]{sched_arr}->epoch : undef, realArrival => $stop->[1]{rt_arr} ? $stop->[1]{rt_arr}->epoch : undef, scheduledDeparture => $stop->[1]{sched_dep} ? $stop->[1]{sched_dep}->epoch : undef, realDeparture => $stop->[1]{rt_dep} ? $stop->[1]{rt_dep}->epoch : undef, } ); } if ( $status->{dep_eva} ) { my @station_descriptions = Travel::Status::DE::IRIS::Stations::get_station( $status->{dep_eva} ); if ( @station_descriptions == 1 ) { ( undef, undef, undef, $ret->{fromStation}{longitude}, $ret->{fromStation}{latitude} ) = @{ $station_descriptions[0] }; } } if ( $status->{arr_ds100} ) { my @station_descriptions = Travel::Status::DE::IRIS::Stations::get_station( $status->{arr_ds100} ); if ( @station_descriptions == 1 ) { ( undef, undef, undef, $ret->{toStation}{longitude}, $ret->{toStation}{latitude} ) = @{ $station_descriptions[0] }; } } return $ret; } ); $self->helper( 'journeys_to_map_data' => sub { my ( $self, %opt ) = @_; my @journeys = @{ $opt{journeys} // [] }; my $route_type = $opt{route_type} // 'polybee'; my $include_manual = $opt{include_manual} ? 1 : 0; my $location = $self->app->coordinates_by_station; my $with_polyline = $route_type eq 'beeline' ? 0 : 1; if ( not @journeys ) { return { skipped_journeys => [], station_coordinates => [], polyline_groups => [], }; } my $json = JSON->new->utf8; my $first_departure = $journeys[-1]->{rt_departure}; my $last_departure = $journeys[0]->{rt_departure}; my @stations = List::Util::uniq map { $_->{to_name} } @journeys; push( @stations, List::Util::uniq map { $_->{from_name} } @journeys ); @stations = List::Util::uniq @stations; my @station_coordinates = map { [ $location->{$_}, $_ ] } grep { exists $location->{$_} } @stations; my @station_pairs; my @polylines; my %seen; my @skipped_journeys; my @polyline_journeys = grep { $_->{polyline} } @journeys; my @beeline_journeys = grep { not $_->{polyline} } @journeys; if ( $route_type eq 'polyline' ) { @beeline_journeys = (); } elsif ( $route_type eq 'beeline' ) { push( @beeline_journeys, @polyline_journeys ); @polyline_journeys = (); } for my $journey (@polyline_journeys) { my @polyline = @{ $journey->{polyline} }; my $from_eva = $journey->{from_eva}; my $to_eva = $journey->{to_eva}; my $from_index = first_index { $_->[2] and $_->[2] == $from_eva } @polyline; my $to_index = first_index { $_->[2] and $_->[2] == $to_eva } @polyline; if ( $from_index == -1 or $to_index == -1 ) { # Fall back to route delete $journey->{polyline}; next; } my $key = $from_eva . '!' . $to_eva . '!' . ( $to_index - $from_index ); if ( $seen{$key} ) { next; } $seen{$key} = 1; # direction does not matter at the moment $key = $to_eva . '!' . $from_eva . '!' . ( $to_index - $from_index ); $seen{$key} = 1; @polyline = @polyline[ $from_index .. $to_index ]; my @polyline_coords; for my $coord (@polyline) { push( @polyline_coords, [ $coord->[1], $coord->[0] ] ); } push( @polylines, [@polyline_coords] ); } for my $journey (@beeline_journeys) { my @route = map { $_->[0] } @{ $journey->{route} }; my $from_index = first_index { $_ eq $journey->{from_name} } @route; my $to_index = first_index { $_ eq $journey->{to_name} } @route; if ( $from_index == -1 ) { my $rename = $self->app->renamed_station; $from_index = first_index { ( $rename->{$_} // $_ ) eq $journey->{from_name} } @route; } if ( $to_index == -1 ) { my $rename = $self->app->renamed_station; $to_index = first_index { ( $rename->{$_} // $_ ) eq $journey->{to_name} } @route; } if ( $from_index == -1 or $to_index == -1 ) { push( @skipped_journeys, [ $journey, 'Start/Ziel nicht in Route gefunden' ] ); next; } # Manual journey entries are only included if one of the following # conditions is satisfied: # * their route has more than two elements (-> probably more than just # start and stop station), or # * $include_manual is true (-> user wants to see incomplete routes) # This avoids messing up the map in case an A -> B connection has been # tracked both with a regular checkin (-> detailed route shown on map) # and entered manually (-> beeline also shown on map, typically # significantly differs from detailed route) -- unless the user # sets include_manual, of course. if ( $journey->{edited} & 0x0010 and @route <= 2 and not $include_manual ) { push( @skipped_journeys, [ $journey, 'Manueller Eintrag ohne Unterwegshalte' ] ); next; } @route = @route[ $from_index .. $to_index ]; my $key = join( '|', @route ); if ( $seen{$key} ) { next; } $seen{$key} = 1; # direction does not matter at the moment $seen{ join( '|', reverse @route ) } = 1; my $prev_station = shift @route; for my $station (@route) { push( @station_pairs, [ $prev_station, $station ] ); $prev_station = $station; } } @station_pairs = uniq_by { $_->[0] . '|' . $_->[1] } @station_pairs; @station_pairs = grep { exists $location->{ $_->[0] } and exists $location->{ $_->[1] } } @station_pairs; @station_pairs = map { [ $location->{ $_->[0] }, $location->{ $_->[1] } ] } @station_pairs; my $ret = { skipped_journeys => \@skipped_journeys, station_coordinates => \@station_coordinates, polyline_groups => [ { polylines => $json->encode( \@station_pairs ), color => '#673ab7', opacity => $with_polyline ? 0.4 : 0.6, }, { polylines => $json->encode( \@polylines ), color => '#673ab7', opacity => 0.8, } ], }; if (@station_coordinates) { my @lats = map { $_->[0][0] } @station_coordinates; my @lons = map { $_->[0][1] } @station_coordinates; my $min_lat = List::Util::min @lats; my $max_lat = List::Util::max @lats; my $min_lon = List::Util::min @lons; my $max_lon = List::Util::max @lons; $ret->{bounds} = [ [ $min_lat, $min_lon ], [ $max_lat, $max_lon ] ]; } return $ret; } ); $self->helper( 'get_travel_distance' => sub { my ( $self, $journey ) = @_; my $from = $journey->{from_name}; my $from_eva = $journey->{from_eva}; my $to = $journey->{to_name}; my $to_eva = $journey->{to_eva}; my $route_ref = $journey->{route}; my $polyline_ref = $journey->{polyline}; my $distance_polyline = 0; my $distance_intermediate = 0; my $distance_beeline = 0; my $skipped = 0; my $geo = Geo::Distance->new(); my @stations = map { $_->[0] } @{$route_ref}; my @route = after_incl { $_ eq $from } @stations; @route = before_incl { $_ eq $to } @route; if ( @route < 2 ) { # I AM ERROR return ( 0, 0, 0 ); } my @polyline = after_incl { $_->[2] and $_->[2] == $from_eva } @{ $polyline_ref // [] }; @polyline = before_incl { $_->[2] and $_->[2] == $to_eva } @polyline; my $prev_station = shift @polyline; for my $station (@polyline) { #lonlatlonlat $distance_polyline += $geo->distance( 'kilometer', $prev_station->[0], $prev_station->[1], $station->[0], $station->[1] ); $prev_station = $station; } $prev_station = get_station( shift @route ); if ( not $prev_station ) { return ( $distance_polyline, 0, 0 ); } # Geo-coordinates for stations outside Germany are not available # at the moment. When calculating distance with intermediate stops, # these are simply left out (as if they were not part of the route). # For beeline distance calculation, we use the route's first and last # station with known geo-coordinates. my $from_station_beeline; my $to_station_beeline; # $#{$station} >= 4 iff $station has geocoordinates for my $station_name (@route) { if ( my $station = get_station($station_name) ) { if ( not $from_station_beeline and $#{$prev_station} >= 4 ) { $from_station_beeline = $prev_station; } if ( $#{$station} >= 4 ) { $to_station_beeline = $station; } if ( $#{$prev_station} >= 4 and $#{$station} >= 4 ) { $distance_intermediate += $geo->distance( 'kilometer', $prev_station->[3], $prev_station->[4], $station->[3], $station->[4] ); } else { $skipped++; } $prev_station = $station; } } if ( $from_station_beeline and $to_station_beeline ) { $distance_beeline = $geo->distance( 'kilometer', $from_station_beeline->[3], $from_station_beeline->[4], $to_station_beeline->[3], $to_station_beeline->[4] ); } return ( $distance_polyline, $distance_intermediate, $distance_beeline, $skipped ); } ); $self->helper( 'compute_journey_stats' => sub { my ( $self, @journeys ) = @_; my $km_route = 0; my $km_beeline = 0; my $min_travel_sched = 0; my $min_travel_real = 0; my $delay_dep = 0; my $delay_arr = 0; my $interchange_real = 0; my $num_trains = 0; my $num_journeys = 0; my @inconsistencies; my $next_departure = 0; for my $journey (@journeys) { $num_trains++; $km_route += $journey->{km_route}; $km_beeline += $journey->{km_beeline}; if ( $journey->{sched_duration} and $journey->{sched_duration} > 0 ) { $min_travel_sched += $journey->{sched_duration} / 60; } if ( $journey->{rt_duration} and $journey->{rt_duration} > 0 ) { $min_travel_real += $journey->{rt_duration} / 60; } if ( $journey->{sched_dep_ts} and $journey->{rt_dep_ts} ) { $delay_dep += ( $journey->{rt_dep_ts} - $journey->{sched_dep_ts} ) / 60; } if ( $journey->{sched_arr_ts} and $journey->{rt_arr_ts} ) { $delay_arr += ( $journey->{rt_arr_ts} - $journey->{sched_arr_ts} ) / 60; } # Note that journeys are sorted from recent to older entries if ( $journey->{rt_arr_ts} and $next_departure and $next_departure - $journey->{rt_arr_ts} < ( 60 * 60 ) ) { if ( $next_departure - $journey->{rt_arr_ts} < 0 ) { push( @inconsistencies, epoch_to_dt($next_departure) ->strftime('%d.%m.%Y %H:%M') ); } else { $interchange_real += ( $next_departure - $journey->{rt_arr_ts} ) / 60; } } else { $num_journeys++; } $next_departure = $journey->{rt_dep_ts}; } return { km_route => $km_route, km_beeline => $km_beeline, num_trains => $num_trains, num_journeys => $num_journeys, min_travel_sched => $min_travel_sched, min_travel_real => $min_travel_real, min_interchange_real => $interchange_real, delay_dep => $delay_dep, delay_arr => $delay_arr, inconsistencies => \@inconsistencies, }; } ); $self->helper( 'navbar_class' => sub { my ( $self, $path ) = @_; if ( $self->req->url eq $self->url_for($path) ) { return 'active'; } return q{}; } ); my $r = $self->routes; $r->get('/')->to('traveling#homepage'); $r->get('/about')->to('static#about'); $r->get('/api')->to('api#documentation'); $r->get('/changelog')->to('static#changelog'); $r->get('/impressum')->to('static#imprint'); $r->get('/imprint')->to('static#imprint'); $r->get('/offline')->to('static#offline'); $r->get('/api/v1/:user_action/:token')->to('api#get_v1'); $r->get('/login')->to('account#login_form'); $r->get('/recover')->to('account#request_password_reset'); $r->get('/recover/:id/:token')->to('account#recover_password'); $r->get('/register')->to('account#registration_form'); $r->get('/reg/:id/:token')->to('account#verify'); $r->get('/status/:name')->to('traveling#user_status'); $r->get('/status/:name/:ts')->to('traveling#user_status'); $r->get('/ajax/status/:name')->to('traveling#public_status_card'); $r->get('/ajax/status/:name/:ts')->to('traveling#public_status_card'); $r->post('/api/v1/import')->to('api#import_v1'); $r->post('/api/v1/travel')->to('api#travel_v1'); $r->post('/action')->to('traveling#log_action'); $r->post('/geolocation')->to('traveling#geolocation'); $r->post('/list_departures')->to('traveling#redirect_to_station'); $r->post('/login')->to('account#do_login'); $r->post('/register')->to('account#register'); $r->post('/recover')->to('account#request_password_reset'); my $authed_r = $r->under( sub { my ($self) = @_; if ( $self->is_user_authenticated ) { return 1; } $self->render( 'login', redirect_to => $self->req->url ); return undef; } ); $authed_r->get('/account')->to('account#account'); $authed_r->get('/account/privacy')->to('account#privacy'); $authed_r->get('/account/hooks')->to('account#webhook'); $authed_r->get('/account/insight')->to('account#insight'); $authed_r->get('/ajax/status_card.html')->to('traveling#status_card'); $authed_r->get('/cancelled')->to('traveling#cancelled'); $authed_r->get('/fgr')->to('passengerrights#list_candidates'); $authed_r->get('/account/password')->to('account#password_form'); $authed_r->get('/account/mail')->to('account#change_mail'); $authed_r->get('/export.json')->to('account#json_export'); $authed_r->get('/history.json')->to('traveling#json_history'); $authed_r->get('/history')->to('traveling#history'); $authed_r->get('/history/commute')->to('traveling#commute'); $authed_r->get('/history/map')->to('traveling#map_history'); $authed_r->get('/history/:year')->to('traveling#yearly_history'); $authed_r->get('/history/:year/:month')->to('traveling#monthly_history'); $authed_r->get('/journey/add')->to('traveling#add_journey_form'); $authed_r->get('/journey/comment')->to('traveling#comment_form'); $authed_r->get('/journey/:id')->to('traveling#journey_details'); $authed_r->get('/s/*station')->to('traveling#station'); $authed_r->get('/confirm_mail/:token')->to('account#confirm_mail'); $authed_r->post('/account/privacy')->to('account#privacy'); $authed_r->post('/account/hooks')->to('account#webhook'); $authed_r->post('/account/insight')->to('account#insight'); $authed_r->post('/journey/add')->to('traveling#add_journey_form'); $authed_r->post('/journey/comment')->to('traveling#comment_form'); $authed_r->post('/journey/edit')->to('traveling#edit_journey'); $authed_r->post('/journey/passenger_rights/*filename') ->to('passengerrights#generate'); $authed_r->post('/account/password')->to('account#change_password'); $authed_r->post('/account/mail')->to('account#change_mail'); $authed_r->post('/delete')->to('account#delete'); $authed_r->post('/logout')->to('account#do_logout'); $authed_r->post('/set_token')->to('api#set_token'); } 1;