diff options
Diffstat (limited to 'lib')
| -rwxr-xr-x | lib/Travelynx.pm | 210 | ||||
| -rw-r--r-- | lib/Travelynx/Command/work.pm | 3 | ||||
| -rwxr-xr-x | lib/Travelynx/Controller/Api.pm | 3 | ||||
| -rwxr-xr-x | lib/Travelynx/Controller/Traveling.pm | 9 | ||||
| -rwxr-xr-x | lib/Travelynx/Model/JourneyStatsCache.pm | 100 | ||||
| -rwxr-xr-x | lib/Travelynx/Model/Journeys.pm | 205 |
6 files changed, 296 insertions, 234 deletions
diff --git a/lib/Travelynx.pm b/lib/Travelynx.pm index 551dbc9..edb4637 100755 --- a/lib/Travelynx.pm +++ b/lib/Travelynx.pm @@ -1,4 +1,5 @@ package Travelynx; + # Copyright (C) 2020 Daniel Friesel # # SPDX-License-Identifier: MIT @@ -27,6 +28,7 @@ use Travelynx::Helper::Sendmail; use Travelynx::Helper::Traewelling; use Travelynx::Model::InTransit; use Travelynx::Model::Journeys; +use Travelynx::Model::JourneyStatsCache; use Travelynx::Model::Traewelling; use Travelynx::Model::Users; use XML::LibXML; @@ -330,11 +332,23 @@ sub startup { ); $self->helper( + journey_stats_cache => sub { + my ($self) = @_; + state $journey_stats_cache + = Travelynx::Model::JourneyStatsCache->new( + log => $self->app->log, + pg => $self->pg, + ); + } + ); + + $self->helper( journeys => sub { my ($self) = @_; state $journeys = Travelynx::Model::Journeys->new( log => $self->app->log, pg => $self->pg, + stats_cache => $self->journey_stats_cache, renamed_station => $self->app->renamed_station, station_by_eva => $self->app->station_by_eva, ); @@ -546,7 +560,7 @@ sub startup { ); } - $self->journeys->invalidate_stats_cache( + $self->journey_stats_cache->invalidate( ts => $cache_ts, db => $db, uid => $uid @@ -756,7 +770,7 @@ sub startup { month => $+{month} ); } - $self->journeys->invalidate_stats_cache( + $self->journey_stats_cache->invalidate( ts => $cache_ts, db => $db, uid => $uid @@ -970,109 +984,6 @@ sub startup { ); $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->journeys->get( - 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( 'add_route_timestamps' => sub { my ( $self, $uid, $train, $is_departure ) = @_; @@ -2546,95 +2457,6 @@ sub startup { ); $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}; - } - my $ret = { - 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, - }; - for my $key ( - qw(min_travel_sched min_travel_real min_interchange_real delay_dep delay_arr) - ) - { - my $strf_key = $key . '_strf'; - my $value = $ret->{$key}; - $ret->{$strf_key} = q{}; - if ( $ret->{$key} < 0 ) { - $ret->{$strf_key} .= '-'; - $value *= -1; - } - $ret->{$strf_key} - .= sprintf( '%02d:%02d', $value / 60, $value % 60 ); - } - return $ret; - } - ); - - $self->helper( 'navbar_class' => sub { my ( $self, $path ) = @_; diff --git a/lib/Travelynx/Command/work.pm b/lib/Travelynx/Command/work.pm index f9b78b6..16b41b2 100644 --- a/lib/Travelynx/Command/work.pm +++ b/lib/Travelynx/Command/work.pm @@ -1,4 +1,5 @@ package Travelynx::Command::work; + # Copyright (C) 2020 Daniel Friesel # # SPDX-License-Identifier: MIT @@ -293,7 +294,7 @@ sub run { # own by-year journey log. for my $user ( $db->select( 'users', 'id', { status => 1 } )->hashes->each ) { - $self->app->get_journey_stats( + $self->app->journeys->get_stats( uid => $user->{id}, year => $now->year ); diff --git a/lib/Travelynx/Controller/Api.pm b/lib/Travelynx/Controller/Api.pm index 3a2e100..5811c54 100755 --- a/lib/Travelynx/Controller/Api.pm +++ b/lib/Travelynx/Controller/Api.pm @@ -1,4 +1,5 @@ package Travelynx::Controller::Api; + # Copyright (C) 2020 Daniel Friesel # # SPDX-License-Identifier: MIT @@ -547,7 +548,7 @@ sub import_v1 { ); } else { - $self->journeys->invalidate_stats_cache( + $self->journey_stats_cache->invalidate( ts => $opt{rt_departure}, db => $db, uid => $uid diff --git a/lib/Travelynx/Controller/Traveling.pm b/lib/Travelynx/Controller/Traveling.pm index a1c9a7d..842af32 100755 --- a/lib/Travelynx/Controller/Traveling.pm +++ b/lib/Travelynx/Controller/Traveling.pm @@ -1,4 +1,5 @@ package Travelynx::Controller::Traveling; + # Copyright (C) 2020 Daniel Friesel # # SPDX-License-Identifier: MIT @@ -917,7 +918,10 @@ sub yearly_history { before => $interval_end, with_datetime => 1 ); - $stats = $self->get_journey_stats( year => $year ); + $stats = $self->journeys->get_stats( + uid => $self->current_user->{id}, + year => $year + ); } $self->respond_to( @@ -979,7 +983,8 @@ sub monthly_history { before => $interval_end, with_datetime => 1 ); - $stats = $self->get_journey_stats( + $stats = $self->journeys->get_stats( + uid => $self->current_user->{id}, year => $year, month => $month ); diff --git a/lib/Travelynx/Model/JourneyStatsCache.pm b/lib/Travelynx/Model/JourneyStatsCache.pm new file mode 100755 index 0000000..145208d --- /dev/null +++ b/lib/Travelynx/Model/JourneyStatsCache.pm @@ -0,0 +1,100 @@ +package Travelynx::Model::JourneyStatsCache; +# Copyright (C) 2020 Daniel Friesel +# +# SPDX-License-Identifier: MIT + +use strict; +use warnings; +use 5.020; +use utf8; + +import JSON; + +sub new { + my ( $class, %opt ) = @_; + + return bless( \%opt, $class ); +} + +sub add { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + + eval { + $db->insert( + 'journey_stats', + { + user_id => $opt{uid}, + year => $opt{year}, + month => $opt{month}, + data => JSON->new->encode($opt{stats}), + } + ); + }; + if ( my $err = $@ ) { + if ( $err =~ m{duplicate key value violates unique constraint} ) + { + # If 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($@); + } + } +} + +sub get { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + + my $stats = $db->select( + 'journey_stats', + ['data'], + { + user_id => $opt{uid}, + year => $opt{year}, + month => $opt{month} + } + )->expand->hash; + + return $stats->{data}; +} + +# 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. +sub invalidate { + my ( $self, %opt ) = @_; + + my $ts = $opt{ts}; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + $db->delete( + 'journey_stats', + { + user_id => $uid, + year => $ts->year, + month => $ts->month, + } + ); + $db->delete( + 'journey_stats', + { + user_id => $uid, + year => $ts->year, + month => 0, + } + ); +} + +1; diff --git a/lib/Travelynx/Model/Journeys.pm b/lib/Travelynx/Model/Journeys.pm index 3a6afd5..f5f5424 100755 --- a/lib/Travelynx/Model/Journeys.pm +++ b/lib/Travelynx/Model/Journeys.pm @@ -1,4 +1,5 @@ package Travelynx::Model::Journeys; + # Copyright (C) 2020 Daniel Friesel # # SPDX-License-Identifier: MIT @@ -85,6 +86,11 @@ sub new { return bless( \%opt, $class ); } +sub stats_cache { + my ($self) = @_; + return $self->{stats_cache}; +} + # Returns (journey id, error) # Must be called during a transaction. # Must perform a rollback on error. @@ -191,7 +197,7 @@ sub add { $journey_id = $db->insert( 'journeys', $entry, { returning => 'id' } ) ->hash->{id}; - $self->invalidate_stats_cache( + $self->stats_cache->invalidate( ts => $opt{rt_departure}, db => $db, uid => $uid @@ -294,7 +300,7 @@ sub update { # 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( + $self->stats_cache->invalidate( ts => $opt{rt_departure}, db => $db, uid => $uid, @@ -371,7 +377,7 @@ sub update { return "update($journey_id): $@"; } if ( $rows == 1 ) { - $self->invalidate_stats_cache( + $self->stats_cache->invalidate( ts => $journey->{rt_departure}, db => $db, uid => $uid, @@ -426,7 +432,7 @@ sub delete { } if ( $rows == 1 ) { - $self->invalidate_stats_cache( + $self->stats_cache->invalidate( ts => epoch_to_dt( $journey->{rt_dep_ts} ), uid => $uid ); @@ -743,18 +749,15 @@ sub get_months_for_year { if ( $row->{year} == $year ) { # TODO delegate query to the (not yet present) JourneyStats model - my $stats = $db->select( - 'journey_stats', - ['data'], - { - user_id => $uid, - year => $year, - month => $row->{month} - } - )->expand->hash; + my $stats = $self->stats_cache->get( + db => $db, + uid => $uid, + year => $year, + month => $row->{month} + ); # undef -> no journeys for this month; empty hash -> no cached stats - $ret[ $row->{month} - 1 ][2] = $stats->{data} // {}; + $ret[ $row->{month} - 1 ][2] = $stats // {}; } } return @ret; @@ -943,33 +946,163 @@ sub get_travel_distance { $distance_beeline, $skipped ); } -# 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. -sub invalidate_stats_cache { - my ( $self, %opt ) = @_; - - my $ts = $opt{ts}; - my $db = $opt{db} // $self->{pg}->db; - my $uid = $opt{uid}; - - $db->delete( - 'journey_stats', +sub compute_stats { + 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 ) { - user_id => $uid, - year => $ts->year, - month => $ts->month, + $min_travel_sched += $journey->{sched_duration} / 60; } - ); - $db->delete( - 'journey_stats', + 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 ) ) { - user_id => $uid, - year => $ts->year, - month => 0, + 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}; + } + my $ret = { + 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, + }; + for my $key ( + qw(min_travel_sched min_travel_real min_interchange_real delay_dep delay_arr) + ) + { + my $strf_key = $key . '_strf'; + my $value = $ret->{$key}; + $ret->{$strf_key} = q{}; + if ( $ret->{$key} < 0 ) { + $ret->{$strf_key} .= '-'; + $value *= -1; + } + $ret->{$strf_key} .= sprintf( '%02d:%02d', $value / 60, $value % 60 ); + } + return $ret; +} + +sub get_stats { + my ( $self, %opt ) = @_; + + if ( $opt{cancelled} ) { + $self->{log} + ->warn('get_journey_stats called with illegal option cancelled => 1'); + return {}; + } + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + 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. + + if ( + my $stats = $self->stats_cache->get( + uid => $uid, + db => $db, + year => $year, + month => $month + ) + ) + { + return $stats; + } + + 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( + uid => $uid, + cancelled => $opt{cancelled} ? 1 : 0, + verbose => 1, + with_polyline => 1, + after => $interval_start, + before => $interval_end + ); + my $stats = $self->compute_stats(@journeys); + + $self->stats_cache->add( + uid => $uid, + db => $db, + year => $year, + month => $month, + stats => $stats ); + + return $stats; } 1; |