diff options
Diffstat (limited to 'lib/DBInfoscreen/Helper/HAFAS.pm')
| -rw-r--r-- | lib/DBInfoscreen/Helper/HAFAS.pm | 598 |
1 files changed, 193 insertions, 405 deletions
diff --git a/lib/DBInfoscreen/Helper/HAFAS.pm b/lib/DBInfoscreen/Helper/HAFAS.pm index 91661a2..cdb84f0 100644 --- a/lib/DBInfoscreen/Helper/HAFAS.pm +++ b/lib/DBInfoscreen/Helper/HAFAS.pm @@ -1,6 +1,6 @@ package DBInfoscreen::Helper::HAFAS; -# Copyright (C) 2011-2020 Daniel Friesel +# Copyright (C) 2011-2022 Birte Kristina Friesel # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -10,6 +10,7 @@ use 5.020; use DateTime; use Encode qw(decode encode); +use Travel::Status::DE::HAFAS; use Mojo::JSON qw(decode_json); use Mojo::Promise; use XML::LibXML; @@ -28,398 +29,216 @@ sub new { } -sub get_json_p { - my ( $self, $cache, $url ) = @_; +sub get_route_p { + my ( $self, %opt ) = @_; my $promise = Mojo::Promise->new; + my $now = DateTime->now( time_zone => 'Europe/Berlin' ); - if ( my $content = $cache->thaw($url) ) { - return $promise->resolve($content); + my $hafas_promise; + + if ( $opt{trip_id} ) { + $hafas_promise = Travel::Status::DE::HAFAS->new_p( + service => $opt{service}, + journey => { + id => $opt{trip_id}, + }, + language => $opt{language}, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $self->{user_agent}->request_timeout(10) + ); + } + elsif ( $opt{train} ) { + $opt{train_req} = $opt{train}->type . ' ' . $opt{train}->train_no; + $opt{train_origin} = $opt{train}->origin; + } + else { + $opt{train_req} = $opt{train_type} . ' ' . $opt{train_no}; } - $self->{log}->debug("get_json_p($url)"); - - $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) - ->then( + $hafas_promise //= Travel::Status::DE::HAFAS->new_p( + journeyMatch => $opt{train_req} =~ s{^- }{}r, + datetime => ( $opt{train} ? $opt{train}->start : $opt{datetime} ), + language => $opt{language}, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $self->{user_agent}->request_timeout(10) + )->then( sub { - my ($tx) = @_; + my ($hafas) = @_; + my @results = $hafas->results; - if ( my $err = $tx->error ) { - $self->{log}->warn( - "hafas->get_json_p($url): HTTP $err->{code} $err->{message}" - ); - $promise->reject( - "GET $url returned HTTP $err->{code} $err->{message}"); - return; + if ( not @results ) { + return Mojo::Promise->reject( + "journeyMatch($opt{train_req}) found no results"); } - my $body - = encode( 'utf-8', decode( 'ISO-8859-15', $tx->res->body ) ); - $body =~ s{^TSLs[.]sls = }{}; - $body =~ s{;$}{}; - $body =~ s{(}{(}g; - $body =~ s{)}{)}g; - - my $json = decode_json($body); - - if ( not $json ) { - $self->{log}->debug("hafas->get_json_p($url): empty response"); - $promise->reject("GET $url returned empty response"); - return; + my $result = $results[0]; + if ( @results > 1 ) { + for my $journey (@results) { + if ( $opt{train_origin} + and ( $journey->route )[0]->loc->name eq + $opt{train_origin} ) + { + $result = $journey; + last; + } + } } - $cache->freeze( $url, $json ); - - $promise->resolve($json); - return; - } - )->catch( - sub { - my ($err) = @_; - $self->{log}->warn("hafas->get_json_p($url): $err"); - $promise->reject($err); - return; + return Travel::Status::DE::HAFAS->new_p( + journey => { + id => $result->id, + }, + language => $opt{language}, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $self->{user_agent}->request_timeout(10) + ); } - )->wait; - - return $promise; -} - -sub get_xml_p { - my ( $self, $cache, $url ) = @_; + ); - my $promise = Mojo::Promise->new; - - if ( my $content = $cache->thaw($url) ) { - return $promise->resolve($content); - } - - $self->{log}->debug("get_xml_p($url)"); - - $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) - ->then( + $hafas_promise->then( sub { - my ($tx) = @_; - - 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; - } - - my $body = decode( 'ISO-8859-15', $tx->res->body ); - - # <SDay text="... > ..."> is invalid XML, but present - # 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&(?= )}{&}; - - # <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; - - # Dito for <HIMMessage [...] lead="[...]<br>[...]"> - # (replace line breaks with space) - while ( $body - =~ s{<HIMMessage([^>]+)lead="([^"]*)<br/?>([^"=]*)"}{<HIMMessage$1lead="$2 $3"}gis - ) - { - } - - # ... and <HIMMessage [...] lead="[...]<>[...]"> - # (replace <> with t$t) - while ( $body - =~ s{<HIMMessage([^>]+)lead="([^"]*)<>([^"=]*)"}{<HIMMessage$1lead="$2⬌$3"}gis - ) - { - } + my ($hafas) = @_; + my $journey = $hafas->result; + my @ret; + my $station_is_past = 1; - # ... and any other HTML tag inside an XML attribute - # (remove them entirely) - while ( $body - =~ s{<HIMMessage([^>]+)lead="([^"]*)<[^>]+>([^"=]*)"}{<HIMMessage$1lead="$2$3"}gis - ) - { + my $num_names = 0; + my $prev_name = q{}; + my $num_directions = 0; + my $prev_direction = q{}; + my $num_operators = 0; + my $prev_operator = q{}; + + for my $stop ( $journey->route ) { + my $prod = $stop->prod_dep // $stop->prod_arr; + if ( $prod and $prod->name and $prod->name ne $prev_name ) { + $num_names++; + $prev_name = $prod->name; + } + if ( $prod + and $prod->operator + and $prod->operator ne $prev_operator ) + { + $num_operators++; + $prev_operator = $prod->operator; + } + if ( $stop->direction and $stop->direction ne $prev_direction ) + { + $num_directions++; + $prev_direction = $stop->direction; + } } - my $tree; + $prev_name = q{}; + $prev_direction = q{}; + $prev_operator = q{}; - eval { $tree = XML::LibXML->load_xml( string => $body ) }; + for my $stop ( $journey->route ) { - if ($@) { - $self->{log}->debug("hafas->get_xml_p($url): $@"); - $cache->freeze( $url, {} ); - $promise->reject; - return; - } + my $prod = $stop->prod_dep // $stop->prod_arr; + my %annotation; + if ( $num_names > 1 + and $prod + and $prod->name + and $prod->name ne $prev_name ) + { + $prev_name = $annotation{prod_name} = $prod->name; + } + if ( $num_operators > 1 + and $prod + and $prod->operator + and $prod->operator ne $prev_operator ) + { + $prev_operator = $annotation{operator} = $prod->operator; + } + if ( $num_directions > 1 + and $stop->direction + and $stop->direction ne $prev_direction ) + { + $prev_direction = $annotation{direction} = $stop->direction; + } - 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, - }; - } + if (%annotation) { + $annotation{is_annotated} = 1; + } - 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} }, + @ret, { - header => $header, - lead => $lead, - display => $display + name => $stop->loc->name, + eva => $stop->loc->eva, + 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, + arr_cancelled => $stop->arr_cancelled, + dep_cancelled => $stop->dep_cancelled, + tz_offset => $stop->tz_offset, + platform => $stop->platform, + sched_platform => $stop->sched_platform, + load => $stop->load, + isAdditional => $stop->is_additional, + isCancelled => ( + ( $stop->arr_cancelled or not $stop->sched_arr ) + and + ( $stop->dep_cancelled or not $stop->sched_dep ) + ), + %annotation, } ); - } - - $cache->freeze( $url, $ret ); - $promise->resolve($ret); - - return; - } - )->catch( - sub { - my ($err) = @_; - $self->{log}->warn("hafas->get_xml_p($url): $err"); - $promise->reject($err); - return; - } - )->wait; - - return $promise; -} - -sub trainsearch_p { - 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'); - } - - # IRIS reports trains with unknown type as type "-". HAFAS thinks otherwise - # and prefers the type to be left out entirely in this case. - $opt{train_req} =~ s{^- }{}; - - my $promise = Mojo::Promise->new; - - $self->get_json_p( $self->{realtime_cache}, - "${base}&date=$opt{date_yy}&trainname=$opt{train_req}" )->then( - sub { - my ($trainsearch) = @_; - - # Fallback: Take first result - my $result = $trainsearch->{suggestions}[0]; - - # Try finding a result for the current date - for my $suggestion ( @{ $trainsearch->{suggestions} // [] } ) { - - # 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} ) + $station_is_past + and not $ret[-1]{isCancelled} + and $now->epoch < ( + $ret[-1]{rt_arr} // $ret[-1]{rt_dep} + // $ret[-1]{sched_arr} // $ret[-1]{sched_dep} // $now + )->epoch ) { - # 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; - } + $station_is_past = 0; } - } - - if ($result) { - - # 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 ); - $promise->resolve($result); - } - else { - $self->{log}->warn( - "hafas->trainsearch_p($opt{train_req}): train not found"); - $promise->reject("Zug $opt{train_req} nicht gefunden"); - } - - # do not propagate $promise->reject's return value to this promise. - # Perl implicitly returns the last statement, so we explicitly return - # nothing to avoid this. - return; - } - )->catch( - sub { - my ($err) = @_; - $self->{log}->warn("hafas->trainsearch_p($opt{train_req}): $err"); - $promise->reject($err); - - # do not propagate $promise->reject's return value to this promise - return; - } - )->wait; - - return $promise; -} - -sub get_route_timestamps_p { - my ( $self, %opt ) = @_; - - my $promise = Mojo::Promise->new; - my $now = DateTime->now( time_zone => 'Europe/Berlin' ); - - if ( $opt{train} ) { - $opt{date_yy} = $opt{train}->start->strftime('%d.%m.%y'); - $opt{date_yyyy} = $opt{train}->start->strftime('%d.%m.%Y'); - $opt{train_req} = $opt{train}->type . ' ' . $opt{train}->train_no; - $opt{train_origin} = $opt{train}->origin; - } - else { - $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" - ) - ); - } - )->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 $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}; - $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} ); + $ret[-1]{isPast} = $station_is_past; + if ( $stop->tz_offset ) { + if ( $stop->sched_arr ) { + $ret[-1]{local_sched_arr} + = $stop->sched_arr->clone->add( + minutes => $stop->tz_offset ); } - 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 ( $stop->sched_dep ) { + $ret[-1]{local_sched_dep} + = $stop->sched_dep->clone->add( + minutes => $stop->tz_offset ); } - 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; + if ( $stop->rt_arr ) { + $ret[-1]{local_rt_arr} = $stop->rt_arr->clone->add( + minutes => $stop->tz_offset ); + } + if ( $stop->rt_dep ) { + $ret[-1]{local_rt_dep} = $stop->rt_dep->clone->add( + minutes => $stop->tz_offset ); } - $ret->{$name}{isPast} = $station_is_past; + $ret[-1]{local_dt_ad} = $ret[-1]{local_rt_arr} + // $ret[-1]{local_sched_arr} // $ret[-1]{local_rt_dep} + // $ret[-1]{local_sched_dep}; + $ret[-1]{local_dt_da} = $ret[-1]{local_rt_dep} + // $ret[-1]{local_sched_dep} // $ret[-1]{local_rt_arr} + // $ret[-1]{local_sched_arr}; } } - $promise->resolve( $ret, $traindelay // {}, $trainsearch_result ); + $promise->resolve( \@ret, $journey, $hafas ); return; } )->catch( sub { - $promise->reject; + my ($err) = @_; + $promise->reject($err); return; } )->wait; @@ -428,68 +247,37 @@ sub get_route_timestamps_p { } # Input: (HAFAS TripID, line number) -# Output: Promise returning a -# https://github.com/public-transport/hafas-client/blob/4/docs/trip.md instance -# on success +# Output: Promise returning a Travel::Status::DE::HAFAS::Journey instance on success sub get_polyline_p { - my ( $self, $trip_id, $line ) = @_; + my ( $self, %opt ) = @_; - my $api = $self->{api}; - my $url = "${api}/trips/${trip_id}?lineName=${line}&polyline=true"; - my $log_url = $url; - my $cache = $self->{realtime_cache}; + my $trip_id = $opt{id}; + my $line = $opt{line}; + my $service = $opt{service}; my $promise = Mojo::Promise->new; - $log_url =~ s{://\K[^:]+:[^@]+\@}{***@}; - - if ( my $content = $cache->thaw($url) ) { - $promise->resolve($content); - $self->{log}->debug("GET $log_url (cached)"); - return $promise; - } - - $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) - ->then( + Travel::Status::DE::HAFAS->new_p( + service => $service, + journey => { + id => $trip_id, + name => $line, + }, + with_polyline => 1, + cache => $self->{realtime_cache}, + promise => 'Mojo::Promise', + user_agent => $self->{user_agent}->request_timeout(10) + )->then( sub { - my ($tx) = @_; - - if ( my $err = $tx->error ) { - $self->{log}->warn( -"hafas->get_polyline_p($log_url): HTTP $err->{code} $err->{message}" - ); - $promise->reject( - "GET $log_url returned HTTP $err->{code} $err->{message}"); - return; - } - - $self->{log}->debug("GET $log_url (OK)"); - my $json = decode_json( $tx->res->body ); - my @coordinate_list; - - for my $feature ( @{ $json->{polyline}{features} } ) { - if ( exists $feature->{geometry}{coordinates} ) { - push( @coordinate_list, $feature->{geometry}{coordinates} ); - } - - #if ($feature->{type} eq 'Feature') { - # say "Feature " . $feature->{properties}{name}; - #} - } - - my $ret = { - name => $json->{line}{name} // '?', - polyline => [@coordinate_list], - raw => $json, - }; + my ($hafas) = @_; + my $journey = $hafas->result; - $cache->freeze( $url, $ret ); - $promise->resolve($ret); + $promise->resolve($journey); return; } )->catch( sub { my ($err) = @_; - $self->{log}->debug("GET $log_url (error: $err)"); + $self->{log}->debug("HAFAS->new_p($trip_id, $line) error: $err"); $promise->reject($err); return; } |