move statistics cache to a separate model class
This commit is contained in:
Daniel Friesel
parent
fe08e98067
commit
77ecd6d034
6 changed files with 296 additions and 234 deletions
210
lib/Travelynx.pm
210
lib/Travelynx.pm
|
|
@ -1,4 +1,5 @@
|
||||||
package Travelynx;
|
package Travelynx;
|
||||||
|
|
||||||
# Copyright (C) 2020 Daniel Friesel
|
# Copyright (C) 2020 Daniel Friesel
|
||||||
#
|
#
|
||||||
# SPDX-License-Identifier: MIT
|
# SPDX-License-Identifier: MIT
|
||||||
|
|
@ -27,6 +28,7 @@ use Travelynx::Helper::Sendmail;
|
||||||
use Travelynx::Helper::Traewelling;
|
use Travelynx::Helper::Traewelling;
|
||||||
use Travelynx::Model::InTransit;
|
use Travelynx::Model::InTransit;
|
||||||
use Travelynx::Model::Journeys;
|
use Travelynx::Model::Journeys;
|
||||||
|
use Travelynx::Model::JourneyStatsCache;
|
||||||
use Travelynx::Model::Traewelling;
|
use Travelynx::Model::Traewelling;
|
||||||
use Travelynx::Model::Users;
|
use Travelynx::Model::Users;
|
||||||
use XML::LibXML;
|
use XML::LibXML;
|
||||||
|
|
@ -329,12 +331,24 @@ 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(
|
$self->helper(
|
||||||
journeys => sub {
|
journeys => sub {
|
||||||
my ($self) = @_;
|
my ($self) = @_;
|
||||||
state $journeys = Travelynx::Model::Journeys->new(
|
state $journeys = Travelynx::Model::Journeys->new(
|
||||||
log => $self->app->log,
|
log => $self->app->log,
|
||||||
pg => $self->pg,
|
pg => $self->pg,
|
||||||
|
stats_cache => $self->journey_stats_cache,
|
||||||
renamed_station => $self->app->renamed_station,
|
renamed_station => $self->app->renamed_station,
|
||||||
station_by_eva => $self->app->station_by_eva,
|
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,
|
ts => $cache_ts,
|
||||||
db => $db,
|
db => $db,
|
||||||
uid => $uid
|
uid => $uid
|
||||||
|
|
@ -756,7 +770,7 @@ sub startup {
|
||||||
month => $+{month}
|
month => $+{month}
|
||||||
);
|
);
|
||||||
}
|
}
|
||||||
$self->journeys->invalidate_stats_cache(
|
$self->journey_stats_cache->invalidate(
|
||||||
ts => $cache_ts,
|
ts => $cache_ts,
|
||||||
db => $db,
|
db => $db,
|
||||||
uid => $uid
|
uid => $uid
|
||||||
|
|
@ -969,109 +983,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(
|
$self->helper(
|
||||||
'add_route_timestamps' => sub {
|
'add_route_timestamps' => sub {
|
||||||
my ( $self, $uid, $train, $is_departure ) = @_;
|
my ( $self, $uid, $train, $is_departure ) = @_;
|
||||||
|
|
@ -2545,95 +2456,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(
|
$self->helper(
|
||||||
'navbar_class' => sub {
|
'navbar_class' => sub {
|
||||||
my ( $self, $path ) = @_;
|
my ( $self, $path ) = @_;
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
package Travelynx::Command::work;
|
package Travelynx::Command::work;
|
||||||
|
|
||||||
# Copyright (C) 2020 Daniel Friesel
|
# Copyright (C) 2020 Daniel Friesel
|
||||||
#
|
#
|
||||||
# SPDX-License-Identifier: MIT
|
# SPDX-License-Identifier: MIT
|
||||||
|
|
@ -293,7 +294,7 @@ sub run {
|
||||||
# own by-year journey log.
|
# own by-year journey log.
|
||||||
for my $user ( $db->select( 'users', 'id', { status => 1 } )->hashes->each )
|
for my $user ( $db->select( 'users', 'id', { status => 1 } )->hashes->each )
|
||||||
{
|
{
|
||||||
$self->app->get_journey_stats(
|
$self->app->journeys->get_stats(
|
||||||
uid => $user->{id},
|
uid => $user->{id},
|
||||||
year => $now->year
|
year => $now->year
|
||||||
);
|
);
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
package Travelynx::Controller::Api;
|
package Travelynx::Controller::Api;
|
||||||
|
|
||||||
# Copyright (C) 2020 Daniel Friesel
|
# Copyright (C) 2020 Daniel Friesel
|
||||||
#
|
#
|
||||||
# SPDX-License-Identifier: MIT
|
# SPDX-License-Identifier: MIT
|
||||||
|
|
@ -547,7 +548,7 @@ sub import_v1 {
|
||||||
);
|
);
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
$self->journeys->invalidate_stats_cache(
|
$self->journey_stats_cache->invalidate(
|
||||||
ts => $opt{rt_departure},
|
ts => $opt{rt_departure},
|
||||||
db => $db,
|
db => $db,
|
||||||
uid => $uid
|
uid => $uid
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
package Travelynx::Controller::Traveling;
|
package Travelynx::Controller::Traveling;
|
||||||
|
|
||||||
# Copyright (C) 2020 Daniel Friesel
|
# Copyright (C) 2020 Daniel Friesel
|
||||||
#
|
#
|
||||||
# SPDX-License-Identifier: MIT
|
# SPDX-License-Identifier: MIT
|
||||||
|
|
@ -917,7 +918,10 @@ sub yearly_history {
|
||||||
before => $interval_end,
|
before => $interval_end,
|
||||||
with_datetime => 1
|
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(
|
$self->respond_to(
|
||||||
|
|
@ -979,7 +983,8 @@ sub monthly_history {
|
||||||
before => $interval_end,
|
before => $interval_end,
|
||||||
with_datetime => 1
|
with_datetime => 1
|
||||||
);
|
);
|
||||||
$stats = $self->get_journey_stats(
|
$stats = $self->journeys->get_stats(
|
||||||
|
uid => $self->current_user->{id},
|
||||||
year => $year,
|
year => $year,
|
||||||
month => $month
|
month => $month
|
||||||
);
|
);
|
||||||
|
|
|
||||||
100
lib/Travelynx/Model/JourneyStatsCache.pm
Executable file
100
lib/Travelynx/Model/JourneyStatsCache.pm
Executable file
|
|
@ -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;
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
package Travelynx::Model::Journeys;
|
package Travelynx::Model::Journeys;
|
||||||
|
|
||||||
# Copyright (C) 2020 Daniel Friesel
|
# Copyright (C) 2020 Daniel Friesel
|
||||||
#
|
#
|
||||||
# SPDX-License-Identifier: MIT
|
# SPDX-License-Identifier: MIT
|
||||||
|
|
@ -85,6 +86,11 @@ sub new {
|
||||||
return bless( \%opt, $class );
|
return bless( \%opt, $class );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
sub stats_cache {
|
||||||
|
my ($self) = @_;
|
||||||
|
return $self->{stats_cache};
|
||||||
|
}
|
||||||
|
|
||||||
# Returns (journey id, error)
|
# Returns (journey id, error)
|
||||||
# Must be called during a transaction.
|
# Must be called during a transaction.
|
||||||
# Must perform a rollback on error.
|
# Must perform a rollback on error.
|
||||||
|
|
@ -191,7 +197,7 @@ sub add {
|
||||||
$journey_id
|
$journey_id
|
||||||
= $db->insert( 'journeys', $entry, { returning => 'id' } )
|
= $db->insert( 'journeys', $entry, { returning => 'id' } )
|
||||||
->hash->{id};
|
->hash->{id};
|
||||||
$self->invalidate_stats_cache(
|
$self->stats_cache->invalidate(
|
||||||
ts => $opt{rt_departure},
|
ts => $opt{rt_departure},
|
||||||
db => $db,
|
db => $db,
|
||||||
uid => $uid
|
uid => $uid
|
||||||
|
|
@ -294,7 +300,7 @@ sub update {
|
||||||
# stats are partitioned by rt_departure -> both the cache for
|
# stats are partitioned by rt_departure -> both the cache for
|
||||||
# the old value (see bottom of this function) and the new value
|
# the old value (see bottom of this function) and the new value
|
||||||
# (here) must be invalidated.
|
# (here) must be invalidated.
|
||||||
$self->invalidate_stats_cache(
|
$self->stats_cache->invalidate(
|
||||||
ts => $opt{rt_departure},
|
ts => $opt{rt_departure},
|
||||||
db => $db,
|
db => $db,
|
||||||
uid => $uid,
|
uid => $uid,
|
||||||
|
|
@ -371,7 +377,7 @@ sub update {
|
||||||
return "update($journey_id): $@";
|
return "update($journey_id): $@";
|
||||||
}
|
}
|
||||||
if ( $rows == 1 ) {
|
if ( $rows == 1 ) {
|
||||||
$self->invalidate_stats_cache(
|
$self->stats_cache->invalidate(
|
||||||
ts => $journey->{rt_departure},
|
ts => $journey->{rt_departure},
|
||||||
db => $db,
|
db => $db,
|
||||||
uid => $uid,
|
uid => $uid,
|
||||||
|
|
@ -426,7 +432,7 @@ sub delete {
|
||||||
}
|
}
|
||||||
|
|
||||||
if ( $rows == 1 ) {
|
if ( $rows == 1 ) {
|
||||||
$self->invalidate_stats_cache(
|
$self->stats_cache->invalidate(
|
||||||
ts => epoch_to_dt( $journey->{rt_dep_ts} ),
|
ts => epoch_to_dt( $journey->{rt_dep_ts} ),
|
||||||
uid => $uid
|
uid => $uid
|
||||||
);
|
);
|
||||||
|
|
@ -743,18 +749,15 @@ sub get_months_for_year {
|
||||||
if ( $row->{year} == $year ) {
|
if ( $row->{year} == $year ) {
|
||||||
|
|
||||||
# TODO delegate query to the (not yet present) JourneyStats model
|
# TODO delegate query to the (not yet present) JourneyStats model
|
||||||
my $stats = $db->select(
|
my $stats = $self->stats_cache->get(
|
||||||
'journey_stats',
|
db => $db,
|
||||||
['data'],
|
uid => $uid,
|
||||||
{
|
year => $year,
|
||||||
user_id => $uid,
|
month => $row->{month}
|
||||||
year => $year,
|
);
|
||||||
month => $row->{month}
|
|
||||||
}
|
|
||||||
)->expand->hash;
|
|
||||||
|
|
||||||
# undef -> no journeys for this month; empty hash -> no cached stats
|
# 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;
|
return @ret;
|
||||||
|
|
@ -943,33 +946,163 @@ sub get_travel_distance {
|
||||||
$distance_beeline, $skipped );
|
$distance_beeline, $skipped );
|
||||||
}
|
}
|
||||||
|
|
||||||
# Statistics are partitioned by real_departure, which must be provided
|
sub compute_stats {
|
||||||
# when calling this function e.g. after journey deletion or editing.
|
my ( $self, @journeys ) = @_;
|
||||||
# If a joureny's real_departure has been edited, this function must be
|
my $km_route = 0;
|
||||||
# called twice: once with the old and once with the new value.
|
my $km_beeline = 0;
|
||||||
sub invalidate_stats_cache {
|
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;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_stats {
|
||||||
my ( $self, %opt ) = @_;
|
my ( $self, %opt ) = @_;
|
||||||
|
|
||||||
my $ts = $opt{ts};
|
if ( $opt{cancelled} ) {
|
||||||
my $db = $opt{db} // $self->{pg}->db;
|
$self->{log}
|
||||||
my $uid = $opt{uid};
|
->warn('get_journey_stats called with illegal option cancelled => 1');
|
||||||
|
return {};
|
||||||
|
}
|
||||||
|
|
||||||
$db->delete(
|
my $uid = $opt{uid};
|
||||||
'journey_stats',
|
my $db = $opt{db} // $self->{pg}->db;
|
||||||
{
|
my $year = $opt{year} // 0;
|
||||||
user_id => $uid,
|
my $month = $opt{month} // 0;
|
||||||
year => $ts->year,
|
|
||||||
month => $ts->month,
|
# 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,
|
||||||
);
|
);
|
||||||
$db->delete(
|
|
||||||
'journey_stats',
|
# I wonder if people will still be traveling by train in the year 3000
|
||||||
{
|
my $interval_end = $interval_start->clone->add( years => 1000 );
|
||||||
user_id => $uid,
|
|
||||||
year => $ts->year,
|
if ( $opt{year} and $opt{month} ) {
|
||||||
month => 0,
|
$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;
|
1;
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue