diff options
Diffstat (limited to 'lib/Travelynx/Helper/HAFAS.pm')
| -rw-r--r-- | lib/Travelynx/Helper/HAFAS.pm | 438 |
1 files changed, 249 insertions, 189 deletions
diff --git a/lib/Travelynx/Helper/HAFAS.pm b/lib/Travelynx/Helper/HAFAS.pm index 6fd5c71..c35dfdb 100644 --- a/lib/Travelynx/Helper/HAFAS.pm +++ b/lib/Travelynx/Helper/HAFAS.pm @@ -1,18 +1,26 @@ package Travelynx::Helper::HAFAS; -# Copyright (C) 2020 Daniel Friesel +# Copyright (C) 2020-2023 Birte Kristina Friesel # # SPDX-License-Identifier: AGPL-3.0-or-later use strict; use warnings; use 5.020; +use utf8; use DateTime; use Encode qw(decode); use JSON; use Mojo::Promise; -use XML::LibXML; +use Mojo::UserAgent; +use Travel::Status::DE::HAFAS; + +sub _epoch { + my ($dt) = @_; + + return $dt ? $dt->epoch : 0; +} sub new { my ( $class, %opt ) = @_; @@ -27,87 +35,133 @@ sub new { return bless( \%opt, $class ); } -sub get_polyline_p { - my ( $self, $train, $trip_id ) = @_; +sub class_to_product { + my ( $self, $hafas ) = @_; + + my $bits = $hafas->get_active_service->{productbits}; + my $ret; + + for my $i ( 0 .. $#{$bits} ) { + $ret->{ 2**$i } + = ref( $bits->[$i] ) eq 'ARRAY' ? $bits->[$i][0] : $bits->[$i]; + } + + return $ret; +} + +sub get_service { + my ( $self, $service ) = @_; + + return Travel::Status::DE::HAFAS::get_service($service); +} + +sub get_departures_p { + my ( $self, %opt ) = @_; + + $opt{service} //= 'ÖBB'; + + my $agent = $self->{user_agent}; + if ( my $proxy = $self->{service_config}{ $opt{service} }{proxy} ) { + $agent = Mojo::UserAgent->new; + $agent->proxy->http($proxy); + $agent->proxy->https($proxy); + } + + my $when = ( + $opt{timestamp} + ? $opt{timestamp}->clone + : DateTime->now( time_zone => 'Europe/Berlin' ) + )->subtract( minutes => $opt{lookbehind} ); + return Travel::Status::DE::HAFAS->new_p( + service => $opt{service}, + station => $opt{eva}, + datetime => $when, + lookahead => $opt{lookahead} + $opt{lookbehind}, + results => 300, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $agent->request_timeout(5), + ); +} + +sub search_location_p { + my ( $self, %opt ) = @_; + + $opt{service} //= 'ÖBB'; + + my $agent = $self->{user_agent}; + if ( my $proxy = $self->{service_config}{ $opt{service} }{proxy} ) { + $agent = Mojo::UserAgent->new; + $agent->proxy->http($proxy); + $agent->proxy->https($proxy); + } + + return Travel::Status::DE::HAFAS->new_p( + service => $opt{service}, + locationSearch => $opt{query}, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $agent->request_timeout(5), + ); +} + +sub get_tripid_p { + my ( $self, %opt ) = @_; - my $line = $train->line // 0; - my $url - = "https://v5.db.transport.rest/trips/${trip_id}?lineName=${line}&polyline=true"; - my $cache = $self->{main_cache}; my $promise = Mojo::Promise->new; - my $version = $self->{version}; - if ( my $content = $cache->thaw($url) ) { - return $promise->resolve($content); + my $train = $opt{train}; + my $train_desc = $train->type . ' ' . $train->train_no; + $train_desc =~ s{^- }{}; + + $opt{service} //= 'ÖBB'; + + my $agent = $self->{user_agent}; + if ( my $proxy = $self->{service_config}{ $opt{service} }{proxy} ) { + $agent = Mojo::UserAgent->new; + $agent->proxy->http($proxy); + $agent->proxy->https($proxy); } - $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) - ->then( + Travel::Status::DE::HAFAS->new_p( + service => $opt{service}, + journeyMatch => $train_desc, + datetime => $train->start, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $agent->request_timeout(10), + )->then( sub { - my ($tx) = @_; + my ($hafas) = @_; + my @results = $hafas->results; - if ( my $err = $tx->error ) { + if ( not @results ) { + $self->{log}->debug("get_tripid_p($train_desc): no results"); $promise->reject( -"hafas->get_polyline_p($url) returned HTTP $err->{code} $err->{message}" - ); + "journeyMatch($train_desc) returned no results"); return; } - my $body = decode( 'utf-8', $tx->res->body ); - my $json = JSON->new->decode($body); - my @station_list; - my @coordinate_list; - - for my $feature ( @{ $json->{polyline}{features} } ) { - if ( exists $feature->{geometry}{coordinates} ) { - my $coord = $feature->{geometry}{coordinates}; - if ( exists $feature->{properties}{type} - and $feature->{properties}{type} eq 'stop' ) - { - push( @{$coord}, $feature->{properties}{id} ); - push( @station_list, $feature->{properties}{name} ); + $self->{log}->debug("get_tripid_p($train_desc): success"); + + my $result = $results[0]; + if ( @results > 1 ) { + for my $journey (@results) { + if ( ( $journey->route )[0]->loc->name eq $train->origin ) { + $result = $journey; + last; } - push( @coordinate_list, $coord ); } } - my $ret = { - name => $json->{line}{name} // '?', - polyline => [@coordinate_list], - raw => $json, - }; - - $cache->freeze( $url, $ret ); - - # borders ("(Gr)" as in "Grenze") are only returned by HAFAS. - # They are not stations. - my $iris_stations = join( '|', $train->route ); - my $hafas_stations - = join( '|', grep { $_ !~ m{\(Gr\)$} } @station_list ); - - # Do not return polyline if it belongs to an entirely different - # train. Trains with longer routes (e.g. due to train number - # changes, which are handled by HAFAS but left out in IRIS) - # are okay though. - if ( $iris_stations ne $hafas_stations - and index( $hafas_stations, $iris_stations ) == -1 ) - { - $self->{log}->info( 'Ignoring polyline for ' - . $train->line - . ": IRIS route does not agree with HAFAS route: $iris_stations != $hafas_stations" - ); - $promise->reject( - "hafas->get_polyline_p($url): polyline route mismatch"); - } - else { - $promise->resolve($ret); - } + $promise->resolve( $result->id ); return; } )->catch( sub { my ($err) = @_; - $promise->reject("hafas->get_polyline_p($url): $err"); + $self->{log}->debug("get_tripid_p($train_desc): error $err"); + $promise->reject($err); return; } )->wait; @@ -115,174 +169,180 @@ sub get_polyline_p { return $promise; } -sub get_json_p { - my ( $self, $url ) = @_; +sub get_journey_p { + my ( $self, %opt ) = @_; - my $cache = $self->{main_cache}; my $promise = Mojo::Promise->new; + my $now = DateTime->now( time_zone => 'Europe/Berlin' ); - if ( my $content = $cache->thaw($url) ) { - return $promise->resolve($content); + $opt{service} //= 'ÖBB'; + + my $agent = $self->{user_agent}; + if ( my $proxy = $self->{service_config}{ $opt{service} }{proxy} ) { + $agent = Mojo::UserAgent->new; + $agent->proxy->http($proxy); + $agent->proxy->https($proxy); } - $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) - ->then( + Travel::Status::DE::HAFAS->new_p( + service => $opt{service}, + journey => { + id => $opt{trip_id}, + }, + with_polyline => $opt{with_polyline}, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $agent->request_timeout(10), + )->then( sub { - my ($tx) = @_; + my ($hafas) = @_; + my $journey = $hafas->result; - if ( my $err = $tx->error ) { - $promise->reject( -"hafas->get_json_p($url) returned HTTP $err->{code} $err->{message}" - ); + if ($journey) { + $self->{log}->debug("get_journey_p($opt{trip_id}): success"); + $promise->resolve($journey); return; } - - my $body = decode( 'ISO-8859-15', $tx->res->body ); - - $body =~ s{^TSLs[.]sls = }{}; - $body =~ s{;$}{}; - $body =~ s{(}{(}g; - $body =~ s{)}{)}g; - my $json = JSON->new->decode($body); - $cache->freeze( $url, $json ); - $promise->resolve($json); + $self->{log}->debug("get_journey_p($opt{trip_id}): no journey"); + $promise->reject('no journey'); return; } )->catch( sub { my ($err) = @_; - $self->{log}->info("hafas->get_json_p($url): $err"); - $promise->reject("hafas->get_json_p($url): $err"); + $self->{log}->debug("get_journey_p($opt{trip_id}): error $err"); + $promise->reject($err); return; } )->wait; + return $promise; } -sub get_xml_p { - my ( $self, $url ) = @_; +sub get_route_p { + my ( $self, %opt ) = @_; - my $cache = $self->{realtime_cache}; my $promise = Mojo::Promise->new; + my $now = DateTime->now( time_zone => 'Europe/Berlin' ); + + $opt{service} //= 'ÖBB'; - if ( my $content = $cache->thaw($url) ) { - return $promise->resolve($content); + my $agent = $self->{user_agent}; + if ( my $proxy = $self->{service_config}{ $opt{service} }{proxy} ) { + $agent = Mojo::UserAgent->new; + $agent->proxy->http($proxy); + $agent->proxy->https($proxy); } - $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) - ->then( + Travel::Status::DE::HAFAS->new_p( + service => $opt{service}, + journey => { + id => $opt{trip_id}, + + # name => $opt{train_no}, + }, + with_polyline => $opt{with_polyline}, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $agent->request_timeout(10), + )->then( sub { - my ($tx) = @_; - - if ( my $err = $tx->error ) { - $promise->reject( -"hafas->get_xml_p($url) returned HTTP $err->{code} $err->{message}" - ); - return; - } - - my $body = decode( 'ISO-8859-15', $tx->res->body ); - my $tree; - - my $traininfo = { - station => {}, - messages => [], - }; - - # <SDay text="... > ..."> is invalid XML, but present in - # regardless. As it is the last tag, we just throw it away. - $body =~ s{<SDay [^>]*/>}{}s; - - # More fixes for invalid XML - $body =~ s{P&R}{P&R}; - $body =~ s{Wagen \d+ \K&}{&}; - $body =~ s{Wagen \d+, \d+ \K&}{&}; - - # <Attribute [...] text="[...]"[...]"" /> is invalid XML. - # Work around it. - $body - =~ s{<Attribute([^>]+)text="([^"]*)"([^"=>]*)""}{<Attribute$1text="$2*$3*"}s; - - # Same for <HIMMessage lead="[...]"[...]"[...]" /> - $body - =~ s{<HIMMessage([^>]+)lead="([^"]*)"([^"=>]*)"([^"]*)"}{<Attribute$1text="$2*$3*$4"}s; - - # ... and <HIMMessage [...] lead="[...]<>[...]"> - # (replace <> with t$t) - while ( $body - =~ s{<HIMMessage([^>]+)lead="([^"]*)<>([^"=]*)"}{<HIMMessage$1lead="$2⬌$3"}gis - ) - { - } - - # Dito for <HIMMessage [...] lead="[...]<br>[...]">. - while ( $body - =~ s{<HIMMessage([^>]+)lead="([^"]*)<br/?>([^"=]*)"}{<HIMMessage$1lead="$2 $3"}is - ) - { - } - - # ... and any other HTML tag inside an XML attribute - while ( $body - =~ s{<HIMMessage([^>]+)lead="([^"]*)<[^>]+>([^"=]*)"}{<HIMMessage$1lead="$2$3"}is - ) - { - } - - eval { $tree = XML::LibXML->load_xml( string => $body ) }; - if ( my $err = $@ ) { - if ( $err =~ m{extra content at the end}i ) { - - # We requested XML, but received an HTML error page - # (which was returned with HTTP 200 OK). - $self->{log}->debug("load_xml($url): $err"); + my ($hafas) = @_; + my $journey = $hafas->result; + my $ret = []; + my $polyline; + + my $station_is_past = 1; + for my $stop ( $journey->route ) { + my $entry = { + name => $stop->loc->name, + eva => $stop->loc->eva, + sched_arr => _epoch( $stop->sched_arr ), + sched_dep => _epoch( $stop->sched_dep ), + rt_arr => _epoch( $stop->rt_arr ), + rt_dep => _epoch( $stop->rt_dep ), + arr_delay => $stop->arr_delay, + dep_delay => $stop->dep_delay, + load => $stop->load, + lat => $stop->loc->lat, + lon => $stop->loc->lon, + }; + if ( $stop->tz_offset ) { + $entry->{tz_offset} = $stop->tz_offset; } - else { - # There is invalid XML which we might be able to fix via - # regular expressions, so dump it into the production log. - $self->{log}->info("load_xml($url): $err"); + if ( ( $stop->arr_cancelled or not $stop->sched_arr ) + and ( $stop->dep_cancelled or not $stop->sched_dep ) ) + { + $entry->{isCancelled} = 1; } - $cache->freeze( $url, $traininfo ); - $promise->reject("hafas->get_xml_p($url): $err"); - return; + if ( + $station_is_past + and not $entry->{isCancelled} + and $now->epoch < ( + $entry->{rt_arr} // $entry->{rt_dep} + // $entry->{sched_arr} // $entry->{sched_dep} + // $now->epoch + ) + ) + { + $station_is_past = 0; + } + $entry->{isPast} = $station_is_past; + push( @{$ret}, $entry ); } - for my $station ( $tree->findnodes('/Journey/St') ) { - my $name = $station->getAttribute('name'); - my $adelay = $station->getAttribute('adelay'); - my $ddelay = $station->getAttribute('ddelay'); - $traininfo->{station}{$name} = { - adelay => $adelay, - ddelay => $ddelay, - }; - } + if ( $journey->polyline ) { + my @station_list; + my @coordinate_list; - for my $message ( $tree->findnodes('/Journey/HIMMessage') ) { - my $header = $message->getAttribute('header'); - my $lead = $message->getAttribute('lead'); - my $display = $message->getAttribute('display'); - push( - @{ $traininfo->{messages} }, - { - header => $header, - lead => $lead, - display => $display + for my $coord ( $journey->polyline ) { + if ( $coord->{name} ) { + push( @coordinate_list, + [ $coord->{lon}, $coord->{lat}, $coord->{eva} ] ); + push( @station_list, $coord->{name} ); + } + else { + push( @coordinate_list, + [ $coord->{lon}, $coord->{lat} ] ); } - ); + } + my $iris_stations = join( '|', $opt{train}->route ); + + # borders (Gr" as in "Grenze") are only returned by HAFAS. + # They are not stations. + my $hafas_stations + = join( '|', grep { $_ !~ m{(\(Gr\)|\)Gr)$} } @station_list ); + + if ( $iris_stations eq $hafas_stations + or index( $hafas_stations, $iris_stations ) != -1 ) + { + $polyline = { + from_eva => ( $journey->route )[0]->loc->eva, + to_eva => ( $journey->route )[-1]->loc->eva, + coords => \@coordinate_list, + }; + } + else { + $self->{log}->debug( 'Ignoring polyline for ' + . $opt{train}->line + . ": IRIS route does not agree with HAFAS route: $iris_stations != $hafas_stations" + ); + } } - $cache->freeze( $url, $traininfo ); - $promise->resolve($traininfo); + $self->{log}->debug("get_route_p($opt{trip_id}): success"); + $promise->resolve( $ret, $journey, $polyline ); return; } )->catch( sub { my ($err) = @_; - $self->{log}->info("hafas->get_xml_p($url): $err"); - $promise->reject("hafas->get_xml_p($url): $err"); + $self->{log}->debug("get_route_p($opt{trip_id}): error $err"); + $promise->reject($err); return; } )->wait; + return $promise; } |