From f3beaf2d9eb789a6f745d4606d2e95bbb5ad29ae Mon Sep 17 00:00:00 2001 From: Daniel Friesel Date: Sun, 2 Oct 2022 19:39:29 +0200 Subject: DB: Switch to mgate.exe API --- Changelog | 12 + bin/hafas-m | 103 ++++---- lib/Travel/Status/DE/HAFAS.pm | 335 ++++++++++++++++++++++----- lib/Travel/Status/DE/HAFAS/Result.pm | 41 +--- t/20-db.t | 116 +++++----- t/30-invalid-xml.t | 4 +- "t/in/DB.Berlin Jannowitzbr\303\274cke.json" | 1 + "t/in/DB.Berlin Jannowitzbr\303\274cke.xml" | 1 - 8 files changed, 418 insertions(+), 195 deletions(-) create mode 100644 "t/in/DB.Berlin Jannowitzbr\303\274cke.json" delete mode 100644 "t/in/DB.Berlin Jannowitzbr\303\274cke.xml" diff --git a/Changelog b/Changelog index ff8dabe..61d663b 100644 --- a/Changelog +++ b/Changelog @@ -1,3 +1,15 @@ +git HEAD + + * Use mgate.exe HAFAS interface by default. This introduces several + breaking changes in hafas-m, Travel::Status::DE::HAFAS, and + Travel::StatuS::DE::HAFAS::Result. + * hafas-m: -l/--lang and -L/--ignore-late are no longer supported + * Travel::Status::DE::HAFAS->new: "date" and "time" keys are no longer + supported. Use "datetime" instead. + * Travel::Status::DE::HAFAS->new: "lang" key is no longer supported. + * Travel::Status::DE::HAFAS->new: "mode" key is no longer supported. Set + "arrivals" to a true value to request arrivals instead of departures. + Travel::Status::DE::DeutscheBahn 3.01 - Sat Jun 06 2020 * Fix support for ÖBB and other backends which recently switched from diff --git a/bin/hafas-m b/bin/hafas-m index 8eca084..95e01a9 100755 --- a/bin/hafas-m +++ b/bin/hafas-m @@ -5,17 +5,16 @@ use 5.014; our $VERSION = '3.01'; -use Encode qw(decode); -use Getopt::Long qw(:config no_ignore_case); +use DateTime; +use Encode qw(decode); +use Getopt::Long qw(:config no_ignore_case); use List::MoreUtils qw(uniq); -use List::Util qw(first max); +use List::Util qw(first max); use Travel::Status::DE::HAFAS; my ( $date, $time ); -my $arrivals = 0; -my $ignore_late = 0; -my $types = q{}; -my $language; +my $arrivals = 0; +my $types = q{}; my $developer_mode; my ( $list_services, $service, $hafas_url ); my ( @excluded_mots, @exclusive_mots ); @@ -28,18 +27,16 @@ for my $arg (@ARGV) { } GetOptions( - 'a|arrivals' => \$arrivals, - 'd|date=s' => \$date, - 'h|help' => sub { show_help(0) }, - 'l|lang=s' => \$language, - 'L|ignore-late' => \$ignore_late, - 'm|mot=s' => \$types, - 's|service=s' => \$service, - 't|time=s' => \$time, - 'u|url=s' => \$hafas_url, - 'V|version' => \&show_version, - 'devmode' => \$developer_mode, - 'list' => \$list_services, + 'a|arrivals' => \$arrivals, + 'd|date=s' => \$date, + 'h|help' => sub { show_help(0) }, + 'm|mot=s' => \$types, + 's|service=s' => \$service, + 't|time=s' => \$time, + 'u|url=s' => \$hafas_url, + 'V|version' => \&show_version, + 'devmode' => \$developer_mode, + 'list' => \$list_services, ) or show_help(1); @@ -53,19 +50,53 @@ if ($list_services) { parse_mot_options(); -my $status = Travel::Status::DE::HAFAS->new( - date => $date, - language => $language, +my %opt = ( excluded_mots => \@excluded_mots, exclusive_mots => \@exclusive_mots, station => shift || show_help(1), - time => $time, - mode => $arrivals ? 'arr' : 'dep', + arrivals => $arrivals, developer_mode => $developer_mode, service => $service, url => $hafas_url, ); +if ( $date or $time ) { + my $dt = DateTime->now( time_zone => 'Europe/Berlin' ); + if ($date) { + if ( $date + =~ m{ ^ (? \d{1,2} ) [.] (? \d{1,2} ) [.] (? \d{4})? $ }x + ) + { + $dt->set( + day => $+{day}, + month => $+{month} + ); + if ( $+{year} ) { + $dt->set( year => $+{year} ); + } + } + else { + say "--date must be specified as DD.MM.[YYYY]"; + exit 1; + } + } + if ($time) { + if ( $time =~ m{ ^ (? \d{1,2} ) : (? \d{1,2} ) $ }x ) { + $dt->set( + hour => $+{hour}, + minute => $+{minute} + ); + } + else { + say "--time must be specified as HH:MM"; + exit 1; + } + } + $opt{datetime} = $dt; +} + +my $status = Travel::Status::DE::HAFAS->new(%opt); + sub show_help { my ($code) = @_; @@ -176,7 +207,9 @@ sub display_result { if ( my $err = $status->errstr ) { say STDERR "Request error: ${err}"; - if ( $status->errcode and $status->errcode eq 'H730' ) { + if ( $status->errcode + and ( $status->errcode eq 'H730' or $status->errcode eq 'LOCATION' ) ) + { show_similar_stops(); } exit 2; @@ -192,10 +225,6 @@ for my $m ( $status->messages ) { for my $d ( $status->results ) { - if ( $ignore_late and $d->delay ) { - next; - } - my $info_line = $d->info // q{}; for my $message ( $d->messages ) { @@ -207,7 +236,7 @@ for my $d ( $status->results ) { push( @output, [ - $d->sched_time, + $d->sched_datetime->strftime('%H:%M'), $d->is_cancelled ? 'CANCELED' : ( $d->delay ? sprintf( '%+d', $d->delay ) : q{} ), @@ -255,19 +284,10 @@ Show arrivals instead of departures, including trains ending at the specified station. Note that this causes the output to display the start instead of the end station. -=item B<-d>, B<--date> I
.I.I +=item B<-d>, B<--date> I
.I.[I] Date to list departures for. Default: today. -=item B<-l>, B<--lang> B|B|B|B - -Set language used for additional information. Supports Beutsch (default), -Bnglish, Btalian and dutch (B), depending on the used service. - -=item B<-L>, B<--ignore-late> - -Do not display delayed trains. - =item B<--list> List known HAFAS installations. A HAFAS service from this list can be querie @@ -300,8 +320,7 @@ Time to list departures for. Default: now. =item B<-u>, B<--url> I -Request arrivals/departures using the API entry point at I. Note that the -language and output selection suffix (e.g. "/dn") must not be included here. +Request arrivals/departures using the API entry point at I. Note that B<--mot> will not work when using this opton. =item B<-V>, B<--version> diff --git a/lib/Travel/Status/DE/HAFAS.pm b/lib/Travel/Status/DE/HAFAS.pm index 839a599..2c2b6b5 100644 --- a/lib/Travel/Status/DE/HAFAS.pm +++ b/lib/Travel/Status/DE/HAFAS.pm @@ -10,6 +10,9 @@ no if $] >= 5.018, warnings => 'experimental::smartmatch'; use Carp qw(confess); use DateTime; use DateTime::Format::Strptime; +use Digest::MD5 qw(md5_hex); +use Encode qw(decode encode); +use JSON; use List::Util qw(any); use LWP::UserAgent; use POSIX qw(strftime); @@ -33,9 +36,24 @@ my %hafas_instance = ( stopfinder => 'https://reiseauskunft.bahn.de/bin/ajax-getstop.exe', trainsearch => 'https://reiseauskunft.bahn.de/bin/trainsearch.exe', traininfo => 'https://reiseauskunft.bahn.de/bin/traininfo.exe', + mgate => 'https://reiseauskunft.bahn.de/bin/mgate.exe', name => 'Deutsche Bahn', - productbits => - [qw[ice ic_ec d regio s bus ferry u tram ondemand x x x x]], + productbits => [qw[ice ic_ec d regio s bus ferry u tram ondemand]], + salt => 'bdI8UVj4' . '0K5fvxwf', + request => { + client => { + id => 'DB', + v => '20100000', + type => 'IPH', + name => 'DB Navigator', + }, + ext => 'DB.R21.12.a', + ver => '1.15', + auth => { + type => 'AID', + aid => 'n91dB8Z77MLdoR0K' + }, + }, }, NAHSH => { url => 'https://nah.sh.hafas.de/bin/stboard.exe', @@ -50,17 +68,17 @@ my %hafas_instance = ( productbits => [qw[ice ice regio regio regio tram bus ondemand]], }, NVV => { - url => 'https://auskunft.nvv.de/auskunft/bin/jp/stboard.exe', + url => 'https://auskunft.nvv.de/auskunft/bin/jp/stboard.exe', stopfinder => 'https://auskunft.nvv.de/auskunft/bin/jp/ajax-getstop.exe', - name => 'Nordhessischer VerkehrsVerbund', + name => 'Nordhessischer VerkehrsVerbund', productbits => [qw[ice ic_ec regio s u tram bus bus ferry ondemand regio regio]], }, 'ÖBB' => { - url => 'https://fahrplan.oebb.at/bin/stboard.exe', - stopfinder => 'https://fahrplan.oebb.at/bin/ajax-getstop.exe', - name => 'Österreichische Bundesbahnen', + url => 'https://fahrplan.oebb.at/bin/stboard.exe', + stopfinder => 'https://fahrplan.oebb.at/bin/ajax-getstop.exe', + name => 'Österreichische Bundesbahnen', productbits => [qw[ice ice ice regio regio s bus ferry u tram ice ondemand ice]], }, @@ -94,11 +112,6 @@ my %hafas_instance = ( sub new { my ( $obj, %conf ) = @_; - - my $date = $conf{date} // strftime( '%d.%m.%Y', localtime(time) ); - my $time = $conf{time} // strftime( '%H:%M', localtime(time) ); - my $lang = $conf{language} // 'd'; - my $mode = $conf{mode} // 'dep'; my $service = $conf{service}; my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } }; @@ -107,14 +120,12 @@ sub new { $ua->env_proxy; - my $reply; - if ( not $conf{station} ) { confess('You need to specify a station'); } if ( not defined $service and not defined $conf{url} ) { - $service = 'DB'; + $service = $conf{service} = 'DB'; } if ( defined $service and not exists $hafas_instance{$service} ) { @@ -123,6 +134,7 @@ sub new { my $ref = { active_service => $service, + arrivals => $conf{arrivals}, developer_mode => $conf{developer_mode}, exclusive_mots => $conf{exclusive_mots}, excluded_mots => $conf{excluded_mots}, @@ -130,41 +142,172 @@ sub new { results => [], station => $conf{station}, ua => $ua, - post => { - input => $conf{station}, - date => $date, - time => $time, - start => 'yes', # value doesn't matter, just needs to be set - boardType => $mode, - L => 'vs_java3', - }, + now => DateTime->now( time_zone => 'Europe/Berlin' ), }; bless( $ref, $obj ); - $ref->set_productfilter; + if ( $hafas_instance{$service}{mgate} ) { + return $ref->new_mgate(%conf); + } + return $ref->new_legacy(%conf); +} + +sub new_mgate { + my ( $self, %conf ) = @_; + my $json = JSON->new->utf8; + my $service = $conf{service}; + + my $now = $self->{now}; + my $date = ( $conf{datetime} // $now )->strftime('%Y%m%d'); + my $time = ( $conf{datetime} // $now )->strftime('%H%M%S'); + + my $lid; + if ( $self->{station} =~ m{ ^ [0-9]+ $ }x ) { + $lid = 'A=1@L=' . $self->{station} . '@'; + } + else { + $lid = 'A=1@O=' . $self->{station} . '@'; + } + + my $mot_mask = 1023; + + my %mot_pos; + for my $i ( 0 .. $#{ $hafas_instance{$service}{productbits} } ) { + $mot_pos{ $hafas_instance{$service}{productbits}[$i] } = $i; + } + + if ( my @mots = @{ $self->{exclusive_mots} // [] } ) { + $mot_mask = 0; + for my $mot (@mots) { + $mot_mask |= 1 << $mot_pos{$mot}; + } + } + + if ( my @mots = @{ $self->{excluded_mots} // [] } ) { + for my $mot (@mots) { + $mot_mask &= ~( 1 << $mot_pos{$mot} ); + } + } + + my $req = { + svcReqL => [ + { + req => { + type => ( $conf{arrivals} ? 'ARR' : 'DEP' ), + stbLoc => { lid => $lid }, + dirLoc => undef, + maxJny => 30, + date => $date, + time => $time, + dur => -1, + jnyFltrL => + [ { type => "PROD", mode => "INC", value => $mot_mask } ] + }, + meth => 'StationBoard' + } + ], + client => { + id => 'DB', + v => '20100000', + type => 'IPH', + name => 'DB Navigator' + }, + ext => 'DB.R21.12.a', + ver => '1.15', + auth => { + type => 'AID', + 'aid' => 'n91dB8Z77MLdoR0K' + } + }; + + $req = $json->encode($req); + $self->{post} = $req; + + my $url = $conf{url} // $hafas_instance{$service}{mgate}; + + if ( my $salt = $hafas_instance{$service}{salt} ) { + $url .= '?checksum=' . md5_hex( $self->{post} . $salt ); + } + + if ( $conf{json} ) { + $self->{raw_json} = $conf{json}; + } + else { + if ( $self->{developer_mode} ) { + say "requesting $req from $url"; + } + + my $reply = $self->{ua}->post( + $url, + 'Content-Type' => 'application/json', + Content => $self->{post} + ); + if ( $reply->is_error ) { + $self->{errstr} = $reply->status_line; + return $self; + } + + if ( $self->{developer_mode} ) { + say decode( 'utf-8', $reply->content ); + } + + $self->{raw_json} = $json->decode( $reply->content ); + } + + $self->check_mgate; + $self->parse_mgate; + + return $self; +} + +sub new_legacy { + my ( $self, %conf ) = @_; + + my $now = $self->{now}; + my $date = ( $conf{datetime} // $now )->strftime('%d.%m.%Y'); + my $time = ( $conf{datetime} // $now )->strftime('%H:%M'); + my $mode = $conf{arrivals} ? 'arr' : 'dep'; + my $lang = 'd'; + my $service = $conf{service}; + + $self->{post} = { + input => $conf{station}, + date => $date, + time => $time, + start => 'yes', # value doesn't matter, just needs to be set + boardType => $mode, + L => 'vs_java3', + }; + + $self->set_productfilter; my $url = ( $conf{url} // $hafas_instance{$service}{url} ) . "/${lang}n"; if ( $conf{xml} ) { - $ref->{raw_xml} = $conf{xml}; + + # used for testing + $self->{raw_xml} = $conf{xml}; } else { - $reply = $ua->post( $url, $ref->{post} ); + if ( $self->{developer_mode} ) { + say "requesting from $url"; + } + my $reply = $self->{ua}->post( $url, $self->{post} ); if ( $reply->is_error ) { - $ref->{errstr} = $reply->status_line; - return $ref; + $self->{errstr} = $reply->status_line; + return $self; } - $ref->{raw_xml} = $reply->content; + $self->{raw_xml} = $reply->content; } # the interface often does not return valid XML (but it's close!) - if ( substr( $ref->{raw_xml}, 0, 5 ) ne '{raw_xml} + if ( substr( $self->{raw_xml}, 0, 5 ) ne '{raw_xml} = '' - . $ref->{raw_xml} + . $self->{raw_xml} . ''; } @@ -172,7 +315,7 @@ sub new { # Returns invalid XML with tags inside HIMMessage's lead attribute. # Fix this. - $ref->{raw_xml} + $self->{raw_xml} =~ s{ lead = " \K ( [^"]+ ) }{ $1 =~ s{ < [^>]+ > }{}grx }egx; } @@ -180,23 +323,23 @@ sub new { # errors in delay="...") when setting the language to dutch/italian. # No, I don't know why. - eval { $ref->{tree} = XML::LibXML->load_xml( string => $ref->{raw_xml} ) }; + eval { $self->{tree} = XML::LibXML->load_xml( string => $self->{raw_xml} ) }; if ( my $err = $@ ) { - if ( $ref->{developer_mode} ) { - say $ref->{raw_xml}; + if ( $self->{developer_mode} ) { + say $self->{raw_xml}; } - $ref->{errstr} = "Backend returned invalid XML: $err"; - return $ref; + $self->{errstr} = "Backend returned invalid XML: $err"; + return $self; } - if ( $ref->{developer_mode} ) { - say $ref->{tree}->toString(1); + if ( $self->{developer_mode} ) { + say $self->{tree}->toString(1); } - $ref->check_input_error; - $ref->prepare_results; - return $ref; + $self->check_input_error; + $self->prepare_results; + return $self; } sub set_productfilter { @@ -254,7 +397,26 @@ sub check_input_error { $self->{errcode} = $err->getAttribute('code'); } - return; + return $self; +} + +sub check_mgate { + my ($self) = @_; + + if ( $self->{raw_json}{cInfo}{code} ne 'OK' ) { + $self->{errstr} = 'cInfo code is ' . $self->{raw_json}{cInfo}{code}; + $self->{errcode} = $self->{raw_json}{cInfo}{code}; + } + elsif ( @{ $self->{raw_json}{svcResL} // [] } == 0 ) { + $self->{errstr} = 'svcResL is empty'; + } + elsif ( $self->{raw_json}{svcResL}[0]{err} ne 'OK' ) { + $self->{errstr} + = 'svcResL[0].err is ' . $self->{raw_json}{svcResL}[0]{err}; + $self->{errcode} = $self->{raw_json}{svcResL}[0]{err}; + } + + return $self; } sub errcode { @@ -289,7 +451,7 @@ sub similar_stops { $self->{errstr} = $err; return; } - return $sf->results; + return $self->results; } return; } @@ -333,9 +495,6 @@ sub prepare_results { $self->{results} = []; - $self->{datetime_now} //= DateTime->now( - time_zone => 'Europe/Berlin', - ); $self->{strptime_obj} //= DateTime::Format::Strptime->new( pattern => '%d.%m.%YT%H:%M', time_zone => 'Europe/Berlin', @@ -388,13 +547,11 @@ sub prepare_results { push( @{ $self->{results} }, Travel::Status::DE::HAFAS::Result->new( - sched_date => $date, sched_datetime => $datetime, - datetime_now => $self->{datetime_now}, + datetime_now => $self->{now}, raw_delay => $delay, raw_e_delay => $e_delay, messages => \@messages, - sched_time => $time, train => $train, operator => $operator, route_end => $dest, @@ -404,6 +561,74 @@ sub prepare_results { ) ); } + return $self; +} + +sub parse_mgate { + my ($self) = @_; + + $self->{results} = []; + + if ( $self->{errstr} ) { + return $self; + } + + $self->{strptime_obj} //= DateTime::Format::Strptime->new( + pattern => '%Y%m%dT%H%M%S', + time_zone => 'Europe/Berlin', + ); + + my @locL = @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] }; + my @prodL = @{ $self->{raw_json}{svcResL}[0]{res}{common}{prodL} // [] }; + my @opL = @{ $self->{raw_json}{svcResL}[0]{res}{common}{opL} // [] }; + my @icoL = @{ $self->{raw_json}{svcResL}[0]{res}{common}{icoL} // [] }; + my @jnyL = @{ $self->{raw_json}{svcResL}[0]{res}{jnyL} // [] }; + + for my $result (@jnyL) { + my $date = $result->{date}; + my $time_s + = $result->{stbStop}{ $self->{arrivals} ? 'aTimeS' : 'dTimeS' }; + my $time_r + = $result->{stbStop}{ $self->{arrivals} ? 'aTimeR' : 'dTimeR' }; + my $datetime_s + = $self->{strptime_obj}->parse_datetime("${date}T${time_s}"); + my $datetime_r + = $time_r + ? $self->{strptime_obj}->parse_datetime("${date}T${time_r}") + : undef; + my $delay + = $datetime_r + ? ( $datetime_r->epoch - $datetime_s->epoch ) / 60 + : undef; + + my $destination = $result->{dirTxt}; + my $is_cancelled = $result->{isCncl}; + my $jid = $result->{jid}; + my $platform = $result->{stbStop}{dPlatfS}; + my $new_platform = $result->{stbStop}{dPlatfR}; + + my $product = $prodL[ $result->{prodX} ]; + my $train = $product->{prodCtx}{name}; + my $train_type = $product->{prodCtx}{catOutS}; + my $line_no = $product->{prodCtx}{line}; + + push( + @{ $self->{results} }, + Travel::Status::DE::HAFAS::Result->new( + sched_datetime => $datetime_s, + rt_datetime => $datetime_r, + datetime => $datetime_r // $datetime_s, + datetime_now => $self->{now}, + delay => $delay, + is_cancelled => $is_cancelled, + train => $train, + route_end => $destination, + platform => $platform, + new_platform => $new_platform, + ) + ); + } + return $self; } sub results { @@ -505,9 +730,9 @@ Supported I are: The station or stop to report for, e.g. "Essen HBf" or "Alfredusbad, Essen (Ruhr)". Mandatory. -=item B => I
.I.I +=item B => I -Date to report for. Defaults to the current day. +Date and time to report for. Defaults to now. =item B => [I, I, ...] @@ -547,10 +772,6 @@ Request results from I, defaults to "DB". See B (and C<< hafas-m --list >>) for a list of supported services. -=item B