From daa8cc5a72bd10d732912595bf0ca2ad3bf167c4 Mon Sep 17 00:00:00 2001
From: Daniel Friesel <derf@finalrewind.org>
Date: Sat, 29 Oct 2022 13:04:01 +0200
Subject: use T-S-DE-HAFAS for train details

---
 lib/DBInfoscreen/Controller/Stationboard.pm | 229 ++++++++++++----------------
 lib/DBInfoscreen/Helper/HAFAS.pm            | 129 ++++++----------
 lib/DBInfoscreen/Helper/Marudor.pm          |   2 +-
 3 files changed, 139 insertions(+), 221 deletions(-)

(limited to 'lib/DBInfoscreen')

diff --git a/lib/DBInfoscreen/Controller/Stationboard.pm b/lib/DBInfoscreen/Controller/Stationboard.pm
index d0d4c13..de1f5e5 100644
--- a/lib/DBInfoscreen/Controller/Stationboard.pm
+++ b/lib/DBInfoscreen/Controller/Stationboard.pm
@@ -698,64 +698,62 @@ sub render_train {
 
 	$self->hafas->get_route_timestamps_p( train => $result )->then(
 		sub {
-			my ( $route_ts, $route_info, $trainsearch ) = @_;
+			my ( $route_ts, $journey ) = @_;
 
-			$departure->{trip_id} = $trainsearch->{trip_id};
+			$departure->{trip_id} = $journey->id;
 
 			# If a train number changes on the way, IRIS routes are incomplete,
 			# whereas HAFAS data has all stops -> merge HAFAS stops into IRIS
 			# stops. This is a rare case, one point where it can be observed is
 			# the TGV service at Frankfurt/Karlsruhe/Mannheim.
-			if ( $route_info
-				and my @hafas_stations = @{ $route_info->{stations} // [] } )
-			{
-				if ( my @iris_stations = @{ $departure->{route_pre_diff} } ) {
-					my @missing_pre;
-					for my $station (@hafas_stations) {
-						if (
-							List::MoreUtils::any { $_->{name} eq $station }
-							@iris_stations
-						  )
+			my @hafas_stations = $journey->route;
+			if ( my @iris_stations = @{ $departure->{route_pre_diff} } ) {
+				my @missing_pre;
+				for my $station (@hafas_stations) {
+					if (
+						List::MoreUtils::any { $_->{name} eq $station->{name} }
+						@iris_stations
+					  )
+					{
+						unshift(
+							@{ $departure->{route_pre_diff} },
+							@missing_pre
+						);
+						last;
+					}
+					push(
+						@missing_pre,
 						{
-							unshift(
-								@{ $departure->{route_pre_diff} },
-								@missing_pre
-							);
-							last;
+							name  => $station->{name},
+							hafas => 1
 						}
+					);
+				}
+			}
+			if ( my @iris_stations = @{ $departure->{route_post_diff} } ) {
+				my @missing_post;
+				for my $station ( reverse @hafas_stations ) {
+					if (
+						List::MoreUtils::any { $_->{name} eq $station->{name} }
+						@iris_stations
+					  )
+					{
 						push(
-							@missing_pre,
-							{
-								name  => $station,
-								hafas => 1
-							}
+							@{ $departure->{route_post_diff} },
+							@missing_post
 						);
+						last;
 					}
-				}
-				if ( my @iris_stations = @{ $departure->{route_post_diff} } ) {
-					my @missing_post;
-					for my $station ( reverse @hafas_stations ) {
-						if (
-							List::MoreUtils::any { $_->{name} eq $station }
-							@iris_stations
-						  )
+					unshift(
+						@missing_post,
 						{
-							push(
-								@{ $departure->{route_post_diff} },
-								@missing_post
-							);
-							last;
+							name  => $station->{name},
+							hafas => 1
 						}
-						unshift(
-							@missing_post,
-							{
-								name  => $station,
-								hafas => 1
-							}
-						);
-					}
+					);
 				}
 			}
+
 			if ($route_ts) {
 				if ( $route_ts->{ $result->station }{rt_bogus} ) {
 
@@ -770,53 +768,30 @@ sub render_train {
 					{
 						$elem->{$key} = $route_ts->{ $elem->{name} }{$key};
 					}
-					if ( $elem->{rt_bogus} ) {
-						$departure->{partially_missing_realtime} = 1;
-					}
 				}
 			}
-			if ( $route_info and @{ $route_info->{messages} // [] } ) {
-				my $him = $route_info->{messages};
-				my @him_messages;
-				$departure->{messages}{him} = $him;
-				for my $message ( @{$him} ) {
-					if ( $message->{display} ) {
-						push(
-							@him_messages,
-							[
-								$message->{header}, { text => $message->{lead} }
-							]
-						);
-						if ( $message->{lead} =~ m{zuginfo.nrw/?\?msg=(\d+)} ) {
-							push(
-								@{ $departure->{links} },
-								[
-									"Großstörung",
-									"https://zuginfo.nrw/?msg=$1"
-								]
-							);
-						}
-					}
+
+			my @him_messages;
+			for my $message ( $journey->messages ) {
+				if ( not $message->code ) {
+					push( @him_messages,
+						[ $message->short // q{}, { text => $message->text } ]
+					);
 				}
-				for my $message ( @{ $departure->{moreinfo} // [] } ) {
-					my $m = $message->[1];
-					@him_messages
-					  = grep { $_->[0] !~ m{Information\. $m\.$} }
-					  @him_messages;
+			}
+			for my $m (@him_messages) {
+				if ( $m->[0] =~ s{: Information.}{:} ) {
+					$m->[1]{icon} = 'info_outline';
 				}
-				for my $m (@him_messages) {
-					if ( $m->[0] =~ s{: Information.}{: } ) {
-						$m->[1]{icon} = 'info_outline';
-					}
-					elsif ( $m->[0] =~ s{: (?:Großs|S)törung.}{: } ) {
-						$m->[1]{icon} = 'warning';
-					}
-					elsif ( $m->[0] =~ s{: Bauarbeiten.}{: } ) {
-						$m->[1]{icon} = 'build';
-					}
+				elsif ( $m->[0] =~ s{: Störung.}{: } ) {
+					$m->[1]{icon} = 'warning';
+				}
+				elsif ( $m->[0] =~ s{: Bauarbeiten.}{: } ) {
+					$m->[1]{icon} = 'build';
 				}
-				unshift( @{ $departure->{moreinfo} }, @him_messages );
+				$m->[0] =~ s{(?!<)->}{ → };
 			}
+			unshift( @{ $departure->{moreinfo} }, @him_messages );
 		}
 	)->catch(
 		sub {
@@ -1029,73 +1004,58 @@ sub train_details {
 	my $linetype = 'bahn';
 
 	$self->hafas->get_route_timestamps_p(
-		train_req => "${train_type} $train_no" )->then(
+		train_type => $train_type,
+		train_no   => $train_no
+	)->then(
 		sub {
-			my ( $route_ts, $route_info, $trainsearch ) = @_;
+			my ( $route_ts, $journey ) = @_;
 
-			$res->{trip_id} = $trainsearch->{trip_id};
+			$res->{trip_id} = $journey->id;
 
-			if ( not defined $trainsearch->{trainClass} ) {
+			if ( not defined $journey->class ) {
 				$linetype = 'ext';
 			}
-			elsif ( $trainsearch->{trainClass} <= 2 ) {
+			elsif ( $journey->class <= 2 ) {
 				$linetype = 'fern';
 			}
-			elsif ( $trainsearch->{trainClass} <= 8 ) {
+			elsif ( $journey->class <= 8 ) {
 				$linetype = 'bahn';
 			}
-			elsif ( $trainsearch->{trainClass} <= 16 ) {
+			elsif ( $journey->class <= 16 ) {
 				$linetype = 'sbahn';
 			}
 
-			$res->{origin}      = $route_info->{stations}[0];
-			$res->{destination} = $route_info->{stations}[-1];
+			$res->{origin}      = $journey->route_start;
+			$res->{destination} = $journey->route_end;
 
 			$res->{route_post_diff}
-			  = [ map { { name => $_ } } @{ $route_info->{stations} } ];
-
-			if ($route_ts) {
-				for my $elem ( @{ $res->{route_post_diff} } ) {
-					for my $key ( keys %{ $route_ts->{ $elem->{name} } // {} } )
-					{
-						$elem->{$key} = $route_ts->{ $elem->{name} }{$key};
-					}
+			  = [ map { { name => $_->{name} } } $journey->route ];
+			for my $elem ( @{ $res->{route_post_diff} } ) {
+				for my $key ( keys %{ $route_ts->{ $elem->{name} } // {} } ) {
+					$elem->{$key} = $route_ts->{ $elem->{name} }{$key};
 				}
 			}
 
-			if ( $route_info and @{ $route_info->{messages} // [] } ) {
-				my $him = $route_info->{messages};
-				my @him_messages;
-				for my $message ( @{$him} ) {
-					if ( $message->{display} ) {
-						push(
-							@him_messages,
-							[
-								$message->{header}, { text => $message->{lead} }
-							]
-						);
-						if ( $message->{lead} =~ m{zuginfo.nrw/?\?msg=(\d+)} ) {
-							push(
-								@{ $res->{links} },
-								[
-									"Großstörung",
-									"https://zuginfo.nrw/?msg=$1"
-								]
-							);
-						}
-					}
+			my @him_messages;
+			for my $message ( $journey->messages ) {
+				if ( not $message->code ) {
+					push( @him_messages,
+						[ $message->short // q{}, { text => $message->text } ]
+					);
 				}
-				for my $m (@him_messages) {
-					if ( $m->[0] =~ s{: Information.}{:} ) {
-						$m->[1]{icon} = 'info_outline';
-					}
-					elsif ( $m->[0] =~ s{: Störung.}{: } ) {
-						$m->[1]{icon} = 'warning';
-					}
-					elsif ( $m->[0] =~ s{: Bauarbeiten.}{: } ) {
-						$m->[1]{icon} = 'build';
-					}
+			}
+			for my $m (@him_messages) {
+				if ( $m->[0] =~ s{: Information.}{:} ) {
+					$m->[1]{icon} = 'info_outline';
+				}
+				elsif ( $m->[0] =~ s{: Störung.}{: } ) {
+					$m->[1]{icon} = 'warning';
+				}
+				elsif ( $m->[0] =~ s{: Bauarbeiten.}{: } ) {
+					$m->[1]{icon} = 'build';
 				}
+			}
+			if (@him_messages) {
 				$res->{moreinfo} = [@him_messages];
 			}
 
@@ -1106,8 +1066,6 @@ sub train_details {
 				icetype   => $self->app->ice_type_map->{ $res->{train_no} },
 				details   => {},    #$departure->{composition} // {},
 				dt_now    => DateTime->now( time_zone => 'Europe/Berlin' ),
-
-				#station_name => "FIXME",#$station_name,
 			);
 		}
 	)->catch(
@@ -1116,7 +1074,8 @@ sub train_details {
 			if ($e) {
 				$self->render(
 					'exception',
-					exception => $e,
+					message   => $e,
+					exception => undef,
 					snapshot  => {}
 				);
 			}
diff --git a/lib/DBInfoscreen/Helper/HAFAS.pm b/lib/DBInfoscreen/Helper/HAFAS.pm
index a13fd4a..b02deea 100644
--- a/lib/DBInfoscreen/Helper/HAFAS.pm
+++ b/lib/DBInfoscreen/Helper/HAFAS.pm
@@ -326,111 +326,70 @@ sub get_route_timestamps_p {
 		$opt{train_origin} = $opt{train}->origin;
 	}
 	else {
+		$opt{train_req} = $opt{train_type} . ' ' . $opt{train_no};
 		$opt{date_yy}   = $now->strftime('%d.%m.%y');
 		$opt{date_yyyy} = $now->strftime('%d.%m.%Y');
 	}
 
-	my $base = 'https://reiseauskunft.bahn.de/bin/traininfo.exe/dn';
-	my ( $trainsearch_result, $trainlink );
-
 	$self->trainsearch_p(%opt)->then(
 		sub {
-			($trainsearch_result) = @_;
-			$trainlink = $trainsearch_result->{trainLink};
-			return Mojo::Promise->all(
-				$self->get_json_p(
-					$self->{realtime_cache},
-					"${base}/${trainlink}?rt=1&date=$opt{date_yy}&L=vs_json"
-				),
-				$self->get_xml_p(
-					$self->{realtime_cache},
-					"${base}/${trainlink}?rt=1&date=$opt{date_yy}&L=vs_java3"
-				)
+			my ($trainsearch_result) = @_;
+			my $trip_id = $trainsearch_result->{trip_id};
+			return Travel::Status::DE::HAFAS->new_p(
+				journey => {
+					id => $trip_id,
+
+					# name => $opt{train_no},
+				},
+				cache      => $self->{realtime_cache},
+				promise    => 'Mojo::Promise',
+				user_agent => $self->{user_agent}->request_timeout(10)
 			);
 		}
 	)->then(
 		sub {
-			my ( $traininfo, $traindelay ) = @_;
-			$traininfo  = $traininfo->[0];
-			$traindelay = $traindelay->[0];
-			if ( not $traininfo or $traininfo->{error} ) {
-				$promise->reject;
-				return;
-			}
-			$trainsearch_result->{trainClass}
-			  = $traininfo->{suggestions}[0]{trainClass};
-			my $ret = {};
-
-			my $strp = DateTime::Format::Strptime->new(
-				pattern   => '%d.%m.%y %H:%M',
-				time_zone => 'Europe/Berlin',
-			);
+			my ($hafas) = @_;
+			my $journey = $hafas->result;
+			my $ret     = {};
 
 			my $station_is_past = 1;
-
-			for
-			  my $station ( @{ $traininfo->{suggestions}[0]{locations} // [] } )
-			{
-				my $name = $station->{name};
-				my $arr  = $station->{arrDate} . ' ' . $station->{arrTime};
-				my $dep  = $station->{depDate} . ' ' . $station->{depTime};
+			for my $stop ( $journey->route ) {
+				my $name = $stop->{name};
 				$ret->{$name} = {
-					sched_arr => scalar $strp->parse_datetime($arr),
-					sched_dep => scalar $strp->parse_datetime($dep),
+					sched_arr   => $stop->{sched_arr},
+					sched_dep   => $stop->{sched_dep},
+					rt_arr      => $stop->{rt_arr},
+					rt_dep      => $stop->{rt_dep},
+					arr_delay   => $stop->{arr_delay},
+					dep_delay   => $stop->{dep_delay},
+					isCancelled => (
+						( $stop->{arr_cancelled} or not $stop->{sched_arr} )
+						  and
+						  ( $stop->{dep_cancelled} or not $stop->{sched_dep} )
+					),
 				};
-				if ( exists $traindelay->{station}{$name} ) {
-					my $delay = $traindelay->{station}{$name};
-					if (    $ret->{$name}{sched_arr}
-						and $delay->{adelay}
-						and $delay->{adelay} =~ m{^\d+$} )
-					{
-						$ret->{$name}{rt_arr} = $ret->{$name}{sched_arr}
-						  ->clone->add( minutes => $delay->{adelay} );
-					}
-					if (    $ret->{$name}{sched_dep}
-						and $delay->{ddelay}
-						and $delay->{ddelay} =~ m{^\d+$} )
-					{
-						$ret->{$name}{rt_dep} = $ret->{$name}{sched_dep}
-						  ->clone->add( minutes => $delay->{ddelay} );
-						if (
-							(
-								defined $delay->{adelay}
-								and $delay->{adelay} eq q{}
-							)
-							or ( defined $delay->{ddelay}
-								and $delay->{ddelay} eq q{} )
-						  )
-						{
-							$ret->{$name}{rt_bogus} = 1;
-						}
-						if ( $delay->{ddelay} and $delay->{ddelay} eq 'cancel' )
-						{
-							$ret->{$name}{isCancelled} = 1;
-						}
-					}
-					if (
-						    $station_is_past
-						and not $ret->{$name}{isCancelled}
-						and $now->epoch < (
-							$ret->{$name}{rt_arr} // $ret->{$name}{rt_dep}
-							  // $ret->{$name}{sched_arr}
-							  // $ret->{$name}{sched_dep} // $now
-						)->epoch
-					  )
-					{
-						$station_is_past = 0;
-					}
-					$ret->{$name}{isPast} = $station_is_past;
+				if (
+					    $station_is_past
+					and not $ret->{$name}{isCancelled}
+					and $now->epoch < (
+						$ret->{$name}{rt_arr} // $ret->{$name}{rt_dep}
+						  // $ret->{$name}{sched_arr}
+						  // $ret->{$name}{sched_dep} // $now
+					)->epoch
+				  )
+				{
+					$station_is_past = 0;
 				}
+				$ret->{$name}{isPast} = $station_is_past;
 			}
 
-			$promise->resolve( $ret, $traindelay // {}, $trainsearch_result );
+			$promise->resolve( $ret, $journey );
 			return;
 		}
 	)->catch(
 		sub {
-			$promise->reject;
+			my ($err) = @_;
+			$promise->reject($err);
 			return;
 		}
 	)->wait;
@@ -453,7 +412,7 @@ sub get_polyline_p {
 		with_polyline => 1,
 		cache         => $self->{realtime_cache},
 		promise       => 'Mojo::Promise',
-		user_agent    => $self->{user_agent}->request_timeout(5)
+		user_agent    => $self->{user_agent}->request_timeout(10)
 	)->then(
 		sub {
 			my ($hafas) = @_;
diff --git a/lib/DBInfoscreen/Helper/Marudor.pm b/lib/DBInfoscreen/Helper/Marudor.pm
index 329c017..15955a3 100644
--- a/lib/DBInfoscreen/Helper/Marudor.pm
+++ b/lib/DBInfoscreen/Helper/Marudor.pm
@@ -9,7 +9,7 @@ use warnings;
 use 5.020;
 
 use DateTime;
-use Encode qw(decode encode);
+use Encode     qw(decode encode);
 use Mojo::JSON qw(decode_json);
 use Mojo::Promise;
 use Mojo::Util qw(url_escape);
-- 
cgit v1.2.3