switch to internal station database; add out-of-service stations for old journeys1.28.0

5 files changed, 371 insertions, 99 deletions

diff --git a/lib/Travelynx/Command/database.pm b/lib/Travelynx/Command/database.pm
index 33612c3..d3a5006 100644
--- a/lib/Travelynx/Command/database.pm
+++ b/lib/Travelynx/Command/database.pm
@@ -6,12 +6,27 @@ package Travelynx::Command::database;
 use Mojo::Base 'Mojolicious::Command';
 
 use DateTime;
+use File::Slurp qw(read_file);
+use JSON;
 use Travel::Status::DE::IRIS::Stations;
 
 has description => 'Initialize or upgrade database layout';
 
 has usage => sub { shift->extract_usage };
 
+sub get_iris_version {
+	my ($db) = @_;
+	my $version;
+
+	eval { $version = $db->select( 'schema_version', ['iris'] )->hash->{iris}; };
+	if ($@) {
+
+		# If it failed, the version table does not exist -> run setup first.
+		return undef;
+	}
+	return $version;
+}
+
 sub get_schema_version {
 	my ($db) = @_;
 	my $version;
@@ -1106,8 +1121,212 @@ my @migrations = (
 			}
 		);
 	},
+
+	# v26 -> v27
+	# add list of stations that are not (or no longer) present in T-S-DE-IRIS
+	# (in this case, stations that were removed up to 1.74)
+	sub {
+		my ($db) = @_;
+		$db->query(
+			qq{
+				alter table schema_version
+					add column iris varchar(12);
+				create table stations (
+					eva int not null primary key,
+					ds100 varchar(16) not null,
+					name varchar(64) not null,
+					lat real not null,
+					lon real not null,
+					source smallint not null,
+					archived bool not null
+				);
+				update schema_version set version = 27;
+				update schema_version set iris = '0';
+			}
+		);
+	},
 );
 
+sub sync_stations {
+	my ( $db, $iris_version ) = @_;
+
+	$db->update( 'schema_version',
+		{ iris => $Travel::Status::DE::IRIS::Stations::VERSION } );
+
+	say 'Updating stations table, this may take a while ...';
+	my $total = scalar Travel::Status::DE::IRIS::Stations::get_stations();
+	my $count = 0;
+	for my $s ( Travel::Status::DE::IRIS::Stations::get_stations() ) {
+		my ( $ds100, $name, $eva, $lon, $lat ) = @{$s};
+		$db->insert(
+			'stations',
+			{
+				eva      => $eva,
+				ds100    => $ds100,
+				name     => $name,
+				lat      => $lat,
+				lon      => $lon,
+				source   => 0,
+				archived => 0
+			},
+			{
+				on_conflict => \
+				  '(eva) do update set archived = false, source = 0'
+			}
+		);
+		if ( $count++ % 1000 == 0 ) {
+			printf( "    %2.0f%% complete\n", $count * 100 / $total );
+		}
+	}
+	say '    done';
+
+	my $res1 = $db->query(
+		qq{
+			select checkin_station_id
+			from journeys
+			left join stations on journeys.checkin_station_id = stations.eva
+			where stations.eva is null
+			limit 1;
+		}
+	)->hash;
+
+	my $res2 = $db->query(
+		qq{
+			select checkout_station_id
+			from journeys
+			left join stations on journeys.checkout_station_id = stations.eva
+			where stations.eva is null
+			limit 1;
+		}
+	)->hash;
+
+	if ( $res1 or $res2 ) {
+		say 'Dropping stats cache for archived stations ...';
+		$db->query('truncate journey_stats;');
+	}
+
+	say 'Updating archived stations ...';
+	my $old_stations
+	  = JSON->new->utf8->decode( scalar read_file('share/old_stations.json') );
+	for my $s ( @{$old_stations} ) {
+		$db->insert(
+			'stations',
+			{
+				eva      => $s->{eva},
+				ds100    => $s->{ds100},
+				name     => $s->{name},
+				lat      => $s->{latlong}[0],
+				lon      => $s->{latlong}[1],
+				source   => 0,
+				archived => 1
+			},
+			{ on_conflict => undef }
+		);
+	}
+
+	if ( $iris_version == 0 ) {
+		say 'Applying EVA ID changes ...';
+		for my $change (
+			[ 721394, 301002, 'RKBP: Kronenplatz (U), Karlsruhe' ],
+			[
+				721356, 901012,
+				'RKME: Ettlinger Tor/Staatstheater (U), Karlsruhe'
+			],
+		  )
+		{
+			my ( $old, $new, $desc ) = @{$change};
+			my $rows = $db->update(
+				'journeys',
+				{ checkout_station_id => $new },
+				{ checkout_station_id => $old }
+			)->rows;
+			$rows += $db->update(
+				'journeys',
+				{ checkin_station_id => $new },
+				{ checkin_station_id => $old }
+			)->rows;
+			if ($rows) {
+				say "$desc ($old -> $new) : $rows rows";
+			}
+		}
+	}
+
+	say 'Checking for unknown EVA IDs ...';
+	my $found = 0;
+
+	$res1 = $db->query(
+		qq{
+			select checkin_station_id
+			from journeys
+			left join stations on journeys.checkin_station_id = stations.eva
+			where stations.eva is null;
+		}
+	);
+
+	$res2 = $db->query(
+		qq{
+			select checkout_station_id
+			from journeys
+			left join stations on journeys.checkout_station_id = stations.eva
+			where stations.eva is null;
+		}
+	);
+
+	my %notified;
+	while ( my $row = $res1->hash ) {
+		my $eva = $row->{checkin_station_id};
+		if ( not $found ) {
+			$found = 1;
+			say '';
+			say '------------8<----------';
+			say 'Travel::Status::DE::IRIS v'
+			  . $Travel::Status::DE::IRIS::Stations::VERSION;
+		}
+		if ( not $notified{$eva} ) {
+			say $eva;
+			$notified{$eva} = 1;
+		}
+	}
+
+	while ( my $row = $res2->hash ) {
+		my $eva = $row->{checkout_station_id};
+		if ( not $found ) {
+			$found = 1;
+			say '';
+			say '------------8<----------';
+			say 'Travel::Status::DE::IRIS v'
+			  . $Travel::Status::DE::IRIS::Stations::VERSION;
+		}
+		if ( not $notified{$eva} ) {
+			say $eva;
+			$notified{$eva} = 1;
+		}
+	}
+
+	if ($found) {
+		say '------------8<----------';
+		say '';
+		say
+'Due to a conceptual flaw in past travelynx releases, your database contains unknown EVA IDs.';
+		say
+'Please file a bug report titled "Missing EVA IDs after DB migration" at https://github.com/derf/travelynx/issues';
+		say 'and include the list shown above in the bug report.';
+		say
+'If you do not have a GitHub account, please send an E-Mail to derf+travelynx@finalrewind.org instead.';
+		say '';
+		say 'This issue does not affect usability or long-term data integrity,';
+		say 'and handling it is not time-critical.';
+		say
+'Past journeys referencing unknown EVA IDs may have inaccurate distance statistics,';
+		say
+'but this will be resolved once a future release handles those EVA IDs.';
+		say 'Note that this issue was already present in previous releases.';
+	}
+	else {
+		say 'None found.';
+	}
+}
+
 sub setup_db {
 	my ($db) = @_;
 	my $tx = $db->begin;
@@ -1129,7 +1348,7 @@ sub migrate_db {
 	say "Found travelynx schema v${schema_version}";
 
 	if ( $schema_version == @migrations ) {
-		say "Database layout is up-to-date";
+		say 'Database layout is up-to-date';
 	}
 
 	eval {
@@ -1144,6 +1363,24 @@ sub migrate_db {
 		exit(1);
 	}
 
+	my $iris_version = get_iris_version($db);
+	say "Found IRIS station database v${iris_version}";
+	if ( $iris_version eq $Travel::Status::DE::IRIS::Stations::VERSION ) {
+		say 'Station database is up-to-date';
+	}
+	else {
+		eval {
+			say
+"Synchronizing with Travel::Status::DE::IRIS $Travel::Status::DE::IRIS::Stations::VERSION";
+			sync_stations( $db, $iris_version );
+		};
+		if ($@) {
+			say STDERR "Synchronization failed: $@";
+			say STDERR "Rolling back to v${schema_version}";
+			exit(1);
+		}
+	}
+
 	if ( get_schema_version($db) == @migrations ) {
 		$tx->commit;
 	}
diff --git a/lib/Travelynx/Controller/Api.pm b/lib/Travelynx/Controller/Api.pm
index 3e9c5eb..f686222 100755
--- a/lib/Travelynx/Controller/Api.pm
+++ b/lib/Travelynx/Controller/Api.pm
@@ -7,7 +7,6 @@ use Mojo::Base 'Mojolicious::Controller';
 
 use DateTime;
 use List::Util;
-use Travel::Status::DE::IRIS::Stations;
 use UUID::Tiny qw(:std);
 
 # Internal Helpers
@@ -184,41 +183,24 @@ sub travel_v1 {
 			return;
 		}
 
-		if (
-			@{
-				[
-					Travel::Status::DE::IRIS::Stations::get_station(
-						$from_station)
-				]
-			} != 1
-		  )
-		{
+		if ( not $self->stations->search($from_station) ) {
 			$self->render(
 				json => {
 					success    => \0,
 					deprecated => \0,
-					error      => 'fromStation is ambiguous',
+					error      => 'Unknown fromStation',
 					status     => $self->get_user_status_json_v1($uid)
 				},
 			);
 			return;
 		}
 
-		if (
-			$to_station
-			and @{
-				[
-					Travel::Status::DE::IRIS::Stations::get_station(
-						$to_station)
-				]
-			} != 1
-		  )
-		{
+		if ( $to_station and not $self->stations->search($to_station) ) {
 			$self->render(
 				json => {
 					success    => \0,
 					deprecated => \0,
-					error      => 'toStation is ambiguous',
+					error      => 'Unknown toStation',
 					status     => $self->get_user_status_json_v1($uid)
 				},
 			);
diff --git a/lib/Travelynx/Helper/IRIS.pm b/lib/Travelynx/Helper/IRIS.pm
index ef179c8..3222dad 100644
--- a/lib/Travelynx/Helper/IRIS.pm
+++ b/lib/Travelynx/Helper/IRIS.pm
@@ -13,6 +13,7 @@ use utf8;
 use Mojo::Promise;
 use Mojo::UserAgent;
 use Travel::Status::DE::IRIS;
+use Travel::Status::DE::IRIS::Stations;
 
 sub new {
 	my ( $class, %opt ) = @_;
diff --git a/lib/Travelynx/Model/Journeys.pm b/lib/Travelynx/Model/Journeys.pm
index a8ca299..3706916 100755
--- a/lib/Travelynx/Model/Journeys.pm
+++ b/lib/Travelynx/Model/Journeys.pm
@@ -6,7 +6,6 @@ package Travelynx::Model::Journeys;
 
 use GIS::Distance;
 use List::MoreUtils qw(after_incl before_incl);
-use Travel::Status::DE::IRIS::Stations;
 
 use strict;
 use warnings;
@@ -35,33 +34,12 @@ sub epoch_to_dt {
 	);
 }
 
-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 grep_unknown_stations {
-	my (@stations) = @_;
+	my ( $self, @stations ) = @_;
 
 	my @unknown_stations;
 	for my $station (@stations) {
-		my $station_info = get_station($station);
+		my $station_info = $self->{stations}->get_by_name($station);
 		if ( not $station_info ) {
 			push( @unknown_stations, $station );
 		}
@@ -100,8 +78,8 @@ sub add {
 	my $db          = $opt{db};
 	my $uid         = $opt{uid};
 	my $now         = DateTime->now( time_zone => 'Europe/Berlin' );
-	my $dep_station = get_station( $opt{dep_station} );
-	my $arr_station = get_station( $opt{arr_station} );
+	my $dep_station = $self->{stations}->search( $opt{dep_station} );
+	my $arr_station = $self->{stations}->search( $opt{arr_station} );
 
 	if ( not $dep_station ) {
 		return ( undef, 'Unbekannter Startbahnhof' );
@@ -134,10 +112,14 @@ sub add {
 	my $route_has_stop  = 0;
 
 	for my $station ( @{ $opt{route} || [] } ) {
-		if ( $station eq $dep_station->[1] or $station eq $dep_station->[0] ) {
+		if (   $station eq $dep_station->{name}
+			or $station eq $dep_station->{ds100} )
+		{
 			$route_has_start = 1;
 		}
-		if ( $station eq $arr_station->[1] or $station eq $arr_station->[0] ) {
+		if (   $station eq $arr_station->{name}
+			or $station eq $arr_station->{ds100} )
+		{
 			$route_has_stop = 1;
 		}
 	}
@@ -145,15 +127,15 @@ sub add {
 	my @route;
 
 	if ( not $route_has_start ) {
-		push( @route, [ $dep_station->[1], {}, undef ] );
+		push( @route, [ $dep_station->{name}, {}, undef ] );
 	}
 
 	if ( $opt{route} ) {
 		my @unknown_stations;
 		for my $station ( @{ $opt{route} } ) {
-			my $station_info = get_station($station);
+			my $station_info = $self->{stations}->search($station);
 			if ($station_info) {
-				push( @route, [ $station_info->[1], {}, undef ] );
+				push( @route, [ $station_info->{name}, {}, undef ] );
 			}
 			else {
 				push( @route,            [ $station, {}, undef ] );
@@ -175,7 +157,7 @@ sub add {
 	}
 
 	if ( not $route_has_stop ) {
-		push( @route, [ $arr_station->[1], {}, undef ] );
+		push( @route, [ $arr_station->{name}, {}, undef ] );
 	}
 
 	my $entry = {
@@ -184,11 +166,11 @@ sub add {
 		train_line          => $opt{train_line},
 		train_no            => $opt{train_no},
 		train_id            => 'manual',
-		checkin_station_id  => $dep_station->[2],
+		checkin_station_id  => $dep_station->{eva},
 		checkin_time        => $now,
 		sched_departure     => $opt{sched_departure},
 		real_departure      => $opt{rt_departure},
-		checkout_station_id => $arr_station->[2],
+		checkout_station_id => $arr_station->{eva},
 		sched_arrival       => $opt{sched_arrival},
 		real_arrival        => $opt{rt_arrival},
 		checkout_time       => $now,
@@ -252,14 +234,14 @@ sub update {
 
 	eval {
 		if ( exists $opt{from_name} ) {
-			my $from_station = get_station( $opt{from_name}, 1 );
+			my $from_station = $self->{stations}->search( $opt{from_name} );
 			if ( not $from_station ) {
 				die("Unbekannter Startbahnhof\n");
 			}
 			$rows = $db->update(
 				'journeys',
 				{
-					checkin_station_id => $from_station->[2],
+					checkin_station_id => $from_station->{eva},
 					edited             => $journey->{edited} | 0x0004,
 				},
 				{
@@ -268,14 +250,14 @@ sub update {
 			)->rows;
 		}
 		if ( exists $opt{to_name} ) {
-			my $to_station = get_station( $opt{to_name}, 1 );
+			my $to_station = $self->{stations}->search( $opt{to_name} );
 			if ( not $to_station ) {
 				die("Unbekannter Zielbahnhof\n");
 			}
 			$rows = $db->update(
 				'journeys',
 				{
-					checkout_station_id => $to_station->[2],
+					checkout_station_id => $to_station->{eva},
 					edited              => $journey->{edited} | 0x0400,
 				},
 				{
@@ -559,13 +541,13 @@ sub get {
 			$ref->{polyline} = $entry->{polyline};
 		}
 
-		if ( my $station = $self->{station_by_eva}->{ $ref->{from_eva} } ) {
-			$ref->{from_ds100} = $station->[0];
-			$ref->{from_name}  = $station->[1];
+		if ( my $station = $self->{stations}->get_by_eva( $ref->{from_eva} ) ) {
+			$ref->{from_ds100} = $station->{ds100};
+			$ref->{from_name}  = $station->{name};
 		}
-		if ( my $station = $self->{station_by_eva}->{ $ref->{to_eva} } ) {
-			$ref->{to_ds100} = $station->[0];
-			$ref->{to_name}  = $station->[1];
+		if ( my $station = $self->{stations}->get_by_eva( $ref->{to_eva} ) ) {
+			$ref->{to_ds100} = $station->{ds100};
+			$ref->{to_name}  = $station->{name};
 		}
 
 		if ( $opt{with_datetime} ) {
@@ -938,7 +920,8 @@ sub sanity_check {
 	}
 	if ( $journey->{edited} & 0x0010 and not $lax ) {
 		my @unknown_stations
-		  = grep_unknown_stations( map { $_->[0] } @{ $journey->{route} } );
+		  = $self->grep_unknown_stations( map { $_->[0] }
+			  @{ $journey->{route} } );
 		if (@unknown_stations) {
 			return 'Unbekannte Station(en): ' . join( ', ', @unknown_stations );
 		}
@@ -989,8 +972,6 @@ sub get_travel_distance {
 
 	my $prev_station = shift @polyline;
 	for my $station (@polyline) {
-
-		#lonlatlonlat
 		$distance_polyline += $geo->distance_metal(
 			$prev_station->[1], $prev_station->[0],
 			$station->[1],      $station->[0]
@@ -998,45 +979,30 @@ sub get_travel_distance {
 		$prev_station = $station;
 	}
 
-	$prev_station = get_station( shift @route );
+	$prev_station = $self->{stations}->get_by_name( 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_metal(
-					$prev_station->[4], $prev_station->[3],
-					$station->[4],      $station->[3]
-				);
-			}
-			else {
-				$skipped++;
-			}
+		if ( my $station = $self->{stations}->get_by_name($station_name) ) {
+			$from_station_beeline //= $prev_station;
+			$to_station_beeline = $station;
+			$distance_intermediate += $geo->distance_metal(
+				$prev_station->{lat}, $prev_station->{lon},
+				$station->{lat},      $station->{lon}
+			);
 			$prev_station = $station;
 		}
 	}
 
 	if ( $from_station_beeline and $to_station_beeline ) {
 		$distance_beeline = $geo->distance_metal(
-			$from_station_beeline->[4], $from_station_beeline->[3],
-			$to_station_beeline->[4],   $to_station_beeline->[3]
+			$from_station_beeline->{lat}, $from_station_beeline->{lon},
+			$to_station_beeline->{lat},   $to_station_beeline->{lon}
 		);
 	}
 
@@ -1264,10 +1230,8 @@ sub get_connection_targets {
 	my @destinations
 	  = $res->hashes->grep( sub { shift->{count} >= $min_count } )
 	  ->map( sub { shift->{dest} } )->each;
-	@destinations
-	  = grep { $self->{station_by_eva}{$_} } @destinations;
-	@destinations
-	  = map { $self->{station_by_eva}{$_}->[1] } @destinations;
+	@destinations = $self->{stations}->get_by_evas(@destinations);
+	@destinations = map { $_->{name} } @destinations;
 	return @destinations;
 }
 
diff --git a/lib/Travelynx/Model/Stations.pm b/lib/Travelynx/Model/Stations.pm
new file mode 100644
index 0000000..6c898b1
--- /dev/null
+++ b/lib/Travelynx/Model/Stations.pm
@@ -0,0 +1,88 @@
+package Travelynx::Model::Stations;
+
+# Copyright (C) 2022 Daniel Friesel
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+use strict;
+use warnings;
+use 5.020;
+
+sub new {
+	my ( $class, %opt ) = @_;
+
+	return bless( \%opt, $class );
+}
+
+# Fast
+sub get_by_eva {
+	my ( $self, $eva, %opt ) = @_;
+
+	if ( not $eva ) {
+		return;
+	}
+
+	my $db = $opt{db} // $self->{pg}->db;
+
+	return $db->select( 'stations', '*', { eva => $eva } )->hash;
+}
+
+# Fast
+sub get_by_evas {
+	my ( $self, @evas ) = @_;
+
+	my @ret
+	  = $self->{pg}->db->select( 'stations', '*', { eva => { '=', \@evas } } )
+	  ->hashes->each;
+	return @ret;
+}
+
+# Slow
+sub get_latlon_by_name {
+	my ( $self, %opt ) = @_;
+
+	my $db = $opt{db} // $self->{pg}->db;
+
+	my %location;
+	my $res = $db->select( 'stations', [ 'name', 'lat', 'lon' ] );
+	while ( my $row = $res->hash ) {
+		$location{ $row->{name} } = [ $row->{lat}, $row->{lon} ];
+	}
+	return \%location;
+}
+
+# Slow
+sub get_by_name {
+	my ( $self, $name, %opt ) = @_;
+
+	my $db = $opt{db} // $self->{pg}->db;
+
+	return $db->select( 'stations', '*', { name => $name }, { limit => 1 } )
+	  ->hash;
+}
+
+# Slow
+sub get_by_ds100 {
+	my ( $self, $ds100, %opt ) = @_;
+
+	my $db = $opt{db} // $self->{pg}->db;
+
+	return $db->select( 'stations', '*', { ds100 => $ds100 }, { limit => 1 } )
+	  ->hash;
+}
+
+# Can be slow
+sub search {
+	my ( $self, $identifier, %opt ) = @_;
+
+	if ( $identifier =~ m{ ^ \d+ $ }x ) {
+		return $self->get_by_eva( $identifier, %opt )
+		  // $self->get_by_ds100( $identifier, %opt )
+		  // $self->get_by_name( $identifier, %opt );
+	}
+
+	return $self->get_by_ds100( $identifier, %opt )
+	  // $self->get_by_name( $identifier, %opt );
+}
+
+1;