move statistics cache to a separate model class (77ecd6d0) · Commits · derf / travelynx

lib/Travelynx.pm

+16 −194

Original line number	Diff line number	Diff line
		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;
		@@ -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(
		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
		@@ -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(
		'add_route_timestamps' => sub {
		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(
		'navbar_class' => sub {
		my ( $self, $path ) = @_;

lib/Travelynx/Command/work.pm

+2 −1

Original line number	Diff line number	Diff line
		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
		);

lib/Travelynx/Controller/Api.pm

+2 −1

Original line number	Diff line number	Diff line
		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

lib/Travelynx/Controller/Traveling.pm

+7 −2

Original line number	Diff line number	Diff line
		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
		);

lib/Travelynx/Model/JourneyStatsCache.pm

0 → 100755

+100 −0

Original line number	Diff line number	Diff line
		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;

Admin message