diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/DBInfoscreen/Controller/Stationboard.pm | 198 | ||||
| -rw-r--r-- | lib/DBInfoscreen/Helper/HAFAS.pm | 322 |
2 files changed, 237 insertions, 283 deletions
diff --git a/lib/DBInfoscreen/Controller/Stationboard.pm b/lib/DBInfoscreen/Controller/Stationboard.pm index c2aa613..3b93ac3 100644 --- a/lib/DBInfoscreen/Controller/Stationboard.pm +++ b/lib/DBInfoscreen/Controller/Stationboard.pm @@ -419,87 +419,6 @@ sub render_train { $departure->{wr_link} = undef; } - my ( $route_ts, $route_info, $trainsearch ) - = $self->hafas->get_route_timestamps( train => $result ); - - $departure->{trip_id} = $trainsearch->{trip_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 - ) - { - unshift( @{ $departure->{route_pre_diff} }, @missing_pre ); - last; - } - push( - @missing_pre, - { - name => $station, - 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 } - @iris_stations - ) - { - push( @{ $departure->{route_post_diff} }, @missing_post ); - last; - } - unshift( - @missing_post, - { - name => $station, - hafas => 1 - } - ); - } - } - } - if ($route_ts) { - for my $elem ( - @{ $departure->{route_pre_diff} }, - @{ $departure->{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; - $departure->{messages}{him} = $him; - for my $message ( @{$him} ) { - if ( $message->{display} ) { - push( @him_messages, [ $message->{header}, $message->{lead} ] ); - } - } - for my $message ( @{ $departure->{moreinfo} // [] } ) { - my $m = $message->[1]; - @him_messages - = grep { $_->[0] !~ m{Information\. $m\.$} } @him_messages; - } - unshift( @{ $departure->{moreinfo} }, @him_messages ); - } - my $linetype = 'bahn'; if ( $departure->{train_type} eq 'S' ) { $linetype = 'sbahn'; @@ -525,14 +444,115 @@ sub render_train { $linetype = 'sbahn'; } - $self->render( - '_train_details', - departure => $departure, - linetype => $linetype, - icetype => $self->app->ice_type_map->{ $departure->{train_no} }, - dt_now => DateTime->now( time_zone => 'Europe/Berlin' ), - station_name => $station_name, - ); + $self->render_later; + + $self->hafas->get_route_timestamps_p( train => $result )->then( + sub { + my ( $route_ts, $route_info, $trainsearch ) = @_; + + $departure->{trip_id} = $trainsearch->{trip_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 + ) + { + unshift( + @{ $departure->{route_pre_diff} }, + @missing_pre + ); + last; + } + push( + @missing_pre, + { + name => $station, + 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 } + @iris_stations + ) + { + push( + @{ $departure->{route_post_diff} }, + @missing_post + ); + last; + } + unshift( + @missing_post, + { + name => $station, + hafas => 1 + } + ); + } + } + } + if ($route_ts) { + for my $elem ( + @{ $departure->{route_pre_diff} }, + @{ $departure->{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; + $departure->{messages}{him} = $him; + for my $message ( @{$him} ) { + if ( $message->{display} ) { + push( @him_messages, + [ $message->{header}, $message->{lead} ] ); + } + } + for my $message ( @{ $departure->{moreinfo} // [] } ) { + my $m = $message->[1]; + @him_messages + = grep { $_->[0] !~ m{Information\. $m\.$} } + @him_messages; + } + unshift( @{ $departure->{moreinfo} }, @him_messages ); + } + } + )->catch( + sub { + # nop + } + )->finally( + sub { + $self->render( + '_train_details', + departure => $departure, + linetype => $linetype, + icetype => $self->app->ice_type_map->{ $departure->{train_no} }, + dt_now => DateTime->now( time_zone => 'Europe/Berlin' ), + station_name => $station_name, + ); + } + )->wait; } sub handle_result { diff --git a/lib/DBInfoscreen/Helper/HAFAS.pm b/lib/DBInfoscreen/Helper/HAFAS.pm index 6c54a51..0206bed 100644 --- a/lib/DBInfoscreen/Helper/HAFAS.pm +++ b/lib/DBInfoscreen/Helper/HAFAS.pm @@ -24,46 +24,13 @@ sub new { } -sub hafas_json_req { - my ( $self, $cache, $url ) = @_; - - if ( my $content = $cache->thaw($url) ) { - return $content; - } - - my $res - = eval { $self->{user_agent}->get( $url => $self->{header} )->result }; - - if ($@) { - $self->{log}->debug("hafas_json_req($url): $@"); - return; - } - if ( $res->is_error ) { - return; - } - - my $body = encode( 'utf-8', decode( 'ISO-8859-15', $res->body ) ); - - $body =~ s{^TSLs[.]sls = }{}; - $body =~ s{;$}{}; - $body =~ s{(}{(}g; - $body =~ s{)}{)}g; - - my $json = decode_json($body); - - $cache->freeze( $url, $json ); - - return $json; -} - sub get_json_p { my ( $self, $cache, $url ) = @_; my $promise = Mojo::Promise->new; if ( my $content = $cache->thaw($url) ) { - $promise->resolve($content); - return $promise; + return $promise->resolve($content); } $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) @@ -106,136 +73,86 @@ sub get_json_p { return $promise; } -sub hafas_xml_req { +sub get_xml_p { my ( $self, $cache, $url ) = @_; - if ( my $content = $cache->thaw($url) ) { - return $content; - } - - my $res - = eval { $self->{user_agent}->get( $url => $self->{header} )->result }; - - if ($@) { - $self->{log}->debug("hafas_xml_req($url): $@"); - return; - } - if ( $res->is_error ) { - $cache->freeze( $url, {} ); - return; - } - - my $body = decode( 'ISO-8859-15', $res->body ); - - # <SDay text="... > ..."> is invalid HTML, but present - # regardless. As it is the last tag, we just throw it away. - $body =~ s{<SDay [^>]*/>}{}s; - - my $tree; - - eval { $tree = XML::LibXML->load_xml( string => $body ) }; + my $promise = Mojo::Promise->new; - if ($@) { - $cache->freeze( $url, {} ); - return; + if ( my $content = $cache->thaw($url) ) { + return $promise->resolve($content); } - my $ret = { - station => {}, - stations => [], - messages => [], - }; - - for my $station ( $tree->findnodes('/Journey/St') ) { - my $name = $station->getAttribute('name'); - my $adelay = $station->getAttribute('adelay'); - my $ddelay = $station->getAttribute('ddelay'); - push( @{ $ret->{stations} }, $name ); - $ret->{station}{$name} = { - adelay => $adelay, - ddelay => $ddelay, - }; - } + $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) + ->then( + sub { + my ($tx) = @_; - for my $message ( $tree->findnodes('/Journey/HIMMessage') ) { - my $header = $message->getAttribute('header'); - my $lead = $message->getAttribute('lead'); - my $display = $message->getAttribute('display'); - push( - @{ $ret->{messages} }, - { - header => $header, - lead => $lead, - display => $display + if ( my $err = $tx->error ) { + $cache->freeze( $url, {} ); + $self->{log}->warn( + "hafas->get_xml_p($url): HTTP $err->{code} $err->{message}" + ); + $promise->reject( + "GET $url returned HTTP $err->{code} $err->{message}"); + return; } - ); - } - $cache->freeze( $url, $ret ); - - return $ret; -} + my $body = decode( 'ISO-8859-15', $tx->res->body ); -sub trainsearch { - my ( $self, %opt ) = @_; - - my $base - = 'https://reiseauskunft.bahn.de/bin/trainsearch.exe/dn?L=vs_json&start=yes&rt=1'; - - if ( not $opt{date_yy} ) { - my $now = DateTime->now( time_zone => 'Europe/Berlin' ); - $opt{date_yy} = $now->strftime('%d.%m.%y'); - $opt{date_yyyy} = $now->strftime('%d.%m.%Y'); - } + # <SDay text="... > ..."> is invalid HTML, but present + # regardless. As it is the last tag, we just throw it away. + $body =~ s{<SDay [^>]*/>}{}s; - my $trainsearch = $self->hafas_json_req( $self->{realtime_cache}, - "${base}&date=$opt{date_yy}&trainname=$opt{train_no}" ); + my $tree; - if ( not $trainsearch ) { - return; - } + eval { $tree = XML::LibXML->load_xml( string => $body ) }; - # Fallback: Take first result - my $result = $trainsearch->{suggestions}[0]; + if ($@) { + $cache->freeze( $url, {} ); + $promise->reject; + return; + } - # Try finding a result for the current date - for my $suggestion ( @{ $trainsearch->{suggestions} // [] } ) { + my $ret = { + station => {}, + stations => [], + messages => [], + }; - # Drunken API, sail with care. Both date formats are used interchangeably - if ( - exists $suggestion->{depDate} - and ( $suggestion->{depDate} eq $opt{date_yy} - or $suggestion->{depDate} eq $opt{date_yyyy} ) - ) - { - # Train numbers are not unique, e.g. IC 149 refers both to the - # InterCity service Amsterdam -> Berlin and to the InterCity service - # Koebenhavns Lufthavn st -> Aarhus. One workaround is making - # requests with the stationFilter=80 parameter. Checking the origin - # station seems to be the more generic solution, so we do that - # instead. - if ( $opt{train_origin} - and $suggestion->{dep} eq $opt{train_origin} ) - { - $result = $suggestion; - last; + for my $station ( $tree->findnodes('/Journey/St') ) { + my $name = $station->getAttribute('name'); + my $adelay = $station->getAttribute('adelay'); + my $ddelay = $station->getAttribute('ddelay'); + push( @{ $ret->{stations} }, $name ); + $ret->{station}{$name} = { + adelay => $adelay, + ddelay => $ddelay, + }; } - } - } - if ($result) { + for my $message ( $tree->findnodes('/Journey/HIMMessage') ) { + my $header = $message->getAttribute('header'); + my $lead = $message->getAttribute('lead'); + my $display = $message->getAttribute('display'); + push( + @{ $ret->{messages} }, + { + header => $header, + lead => $lead, + display => $display + } + ); + } - # The trip_id's date part doesn't seem to matter -- so far, HAFAS is - # happy as long as the date part starts with a number. HAFAS-internal - # tripIDs use this format (withouth leading zero for day of month < 10) - # though, so let's stick with it. - my $date_map = $opt{date_yyyy}; - $date_map =~ tr{.}{}d; - $result->{trip_id} = sprintf( '1|%d|%d|%d|%s', - $result->{id}, $result->{cycle}, $result->{pool}, $date_map ); - } + $cache->freeze( $url, $ret ); + $promise->resolve($ret); - return $result; + return; + } + )->catch( + sub { + } + )->wait; } sub trainsearch_p { @@ -320,9 +237,11 @@ sub trainsearch_p { return $promise; } -sub get_route_timestamps { +sub get_route_timestamps_p { my ( $self, %opt ) = @_; + my $promise = Mojo::Promise->new; + if ( $opt{train} ) { $opt{date_yy} = $opt{train}->start->strftime('%d.%m.%y'); $opt{date_yyyy} = $opt{train}->start->strftime('%d.%m.%Y'); @@ -335,61 +254,76 @@ sub get_route_timestamps { $opt{date_yyyy} = $now->strftime('%d.%m.%Y'); } - my $trainsearch_result = $self->trainsearch(%opt); - - if ( not $trainsearch_result ) { - return; - } - - my $trainlink = $trainsearch_result->{trainLink}; - my $base = 'https://reiseauskunft.bahn.de/bin/traininfo.exe/dn'; + my ( $trainsearch_result, $trainlink, $traininfo ); - my $traininfo = $self->hafas_json_req( $self->{realtime_cache}, - "${base}/${trainlink}?rt=1&date=$opt{date_yy}&L=vs_json" ); + $self->trainsearch_p(%opt)->then( + sub { + ($trainsearch_result) = @_; + $trainlink = $trainsearch_result->{trainLink}; + return $self->get_json_p( $self->{realtime_cache}, + "${base}/${trainlink}?rt=1&date=$opt{date_yy}&L=vs_json" ); + } + )->then( + sub { + ($traininfo) = @_; + if ( not $traininfo or $traininfo->{error} ) { + $promise->reject; + return; + } + return $self->get_xml_p( $self->{realtime_cache}, + "${base}/${trainlink}?rt=1&date=$opt{date_yy}&L=vs_java3" ); + } + )->then( + sub { + my ($traindelay) = @_; + my $ret = {}; - if ( not $traininfo or $traininfo->{error} ) { - return; - } + my $strp = DateTime::Format::Strptime->new( + pattern => '%d.%m.%y %H:%M', + time_zone => 'Europe/Berlin', + ); - my $traindelay = $self->hafas_xml_req( $self->{realtime_cache}, - "${base}/${trainlink}?rt=1&date=$opt{date_yy}&L=vs_java3" ); - - my $ret = {}; - - my $strp = DateTime::Format::Strptime->new( - pattern => '%d.%m.%y %H:%M', - time_zone => 'Europe/Berlin', - ); - - for my $station ( @{ $traininfo->{suggestions}[0]{locations} // [] } ) { - my $name = $station->{name}; - my $arr = $station->{arrDate} . ' ' . $station->{arrTime}; - my $dep = $station->{depDate} . ' ' . $station->{depTime}; - $ret->{$name} = { - sched_arr => scalar $strp->parse_datetime($arr), - sched_dep => scalar $strp->parse_datetime($dep), - }; - if ( exists $traindelay->{station}{$name} ) { - my $delay = $traindelay->{station}{$name}; - if ( $ret->{$name}{sched_arr} - and $delay->{adelay} - and $delay->{adelay} =~ m{^\d+$} ) + for + my $station ( @{ $traininfo->{suggestions}[0]{locations} // [] } ) { - $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} ); + my $name = $station->{name}; + my $arr = $station->{arrDate} . ' ' . $station->{arrTime}; + my $dep = $station->{depDate} . ' ' . $station->{depTime}; + $ret->{$name} = { + sched_arr => scalar $strp->parse_datetime($arr), + sched_dep => scalar $strp->parse_datetime($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} ); + } + } } + + $promise->resolve( $ret, $traindelay // {}, $trainsearch_result ); + return; } - } + )->catch( + sub { + $promise->reject; + return; + } + )->wait; - return ( $ret, $traindelay // {}, $trainsearch_result ); + return $promise; } # Input: (HAFAS TripID, line number) |