Initial Commit

4 files changed, 808 insertions, 0 deletions

diff --git a/bin/dbris b/bin/dbris
new file mode 100755
index 0000000..6b435cc
--- /dev/null
+++ b/bin/dbris
@@ -0,0 +1,367 @@
+#!perl
+use strict;
+use warnings;
+use 5.020;
+
+our $VERSION = '0.01';
+
+use utf8;
+use DateTime;
+use Encode qw(decode);
+use JSON;
+use Getopt::Long qw(:config no_ignore_case);
+use List::Util   qw(max);
+use Travel::Status::DE::DBRIS;
+use Travel::Routing::DE::DBRIS;
+
+my ( $date, $time, $from, $to );
+my $mots;
+my $developer_mode;
+my ( $json_output, $raw_json_output );
+my $use_cache = 1;
+my $cache;
+
+my @output;
+
+binmode( STDOUT, ':encoding(utf-8)' );
+for my $arg (@ARGV) {
+	$arg = decode( 'UTF-8', $arg );
+}
+
+my $output_bold  = -t STDOUT ? "\033[1m" : q{};
+my $output_reset = -t STDOUT ? "\033[0m" : q{};
+
+GetOptions(
+	'd|date=s'  => \$date,
+	'h|help'    => sub { show_help(0) },
+	't|time=s'  => \$time,
+	'V|version' => \&show_version,
+	'cache!'    => \$use_cache,
+	'devmode'   => \$developer_mode,
+	'json'      => \$json_output,
+	'raw-json'  => \$raw_json_output,
+
+) or show_help(1);
+
+if ($use_cache) {
+	my $cache_path = ( $ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache" )
+	  . '/Travel-Status-DE-DBRIS';
+	eval {
+		require Cache::File;
+		$cache = Cache::File->new(
+			cache_root      => $cache_path,
+			default_expires => '90 seconds',
+			lock_level      => Cache::File::LOCK_LOCAL(),
+		);
+	};
+	if ($@) {
+		$cache = undef;
+	}
+}
+
+my ( $from_raw, $to_raw ) = @ARGV;
+
+if ( not( $from_raw and $to_raw ) ) {
+	show_help(1);
+}
+
+sub get_stop {
+	my ($stop) = @_;
+	my $ris = Travel::Status::DE::DBRIS->new(
+		cache          => $cache,
+		locationSearch => $stop,
+		developer_mode => $developer_mode,
+	);
+	if ( my $err = $ris->errstr ) {
+		say STDERR "Request error while looking up '${stop}': ${err}";
+		exit 2;
+	}
+	my $found;
+	for my $result ( $ris->results ) {
+		if ( defined $result->eva ) {
+			return $result;
+		}
+	}
+	say "Could not find stop '${stop}'";
+	exit 1;
+}
+
+my %opt = (
+	from           => get_stop($from_raw),
+	to             => get_stop($to_raw),
+	cache          => $cache,
+	developer_mode => $developer_mode,
+);
+
+if ( $date or $time ) {
+	my $dt = DateTime->now( time_zone => 'Europe/Berlin' );
+	if ($date) {
+		if ( $date
+			=~ m{ ^ (?<day> \d{1,2} ) [.] (?<month> \d{1,2} ) [.] (?<year> \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{ ^ (?<hour> \d{1,2} ) : (?<minute> \d{1,2} ) $ }x ) {
+			$dt->set(
+				hour   => $+{hour},
+				minute => $+{minute},
+				second => 0,
+			);
+		}
+		else {
+			say '--time must be specified as HH:MM';
+			exit 1;
+		}
+	}
+	$opt{datetime} = $dt;
+}
+
+sub show_help {
+	my ($code) = @_;
+
+	print "Usage: dbris [-d dd.mm.yyyy] [-t hh:mm] <from> <to>\n"
+	  . "See also: man dbris-m\n";
+
+	exit $code;
+}
+
+sub show_version {
+	say "dbris version ${VERSION}";
+
+	exit 0;
+}
+
+sub display_occupancy {
+	my ($occupancy) = @_;
+
+	if ( not $occupancy ) {
+		return q{ };
+	}
+	if ( $occupancy == 1 ) {
+		return q{.};
+	}
+	if ( $occupancy == 2 ) {
+		return q{o};
+	}
+	if ( $occupancy == 3 ) {
+		return q{*};
+	}
+	if ( $occupancy == 4 or $occupancy == 99 ) {
+		return q{!};
+	}
+	return q{?};
+}
+
+sub format_occupancy {
+	my ($stop) = @_;
+
+	return display_occupancy( $stop->occupancy_first )
+	  . display_occupancy( $stop->occupancy_second );
+}
+
+sub format_delay {
+	my ( $delay, $len ) = @_;
+	if ( $delay and $len ) {
+		return sprintf( "(%+${len}d)", $delay );
+	}
+	return q{};
+}
+
+my $ris = Travel::Routing::DE::DBRIS->new(%opt);
+
+if ( my $err = $ris->errstr ) {
+	say STDERR "Request error: ${err}";
+	exit 2;
+}
+
+if ($raw_json_output) {
+	say JSON->new->convert_blessed->encode( $ris->{raw_json} );
+	exit 0;
+}
+
+if ($json_output) {
+	say JSON->new->convert_blessed->encode( [ $ris->connections ] );
+	exit 0;
+}
+
+for my $connection ( $ris->connections ) {
+
+	my $header = q{};
+	for my $segment ( $connection->segments ) {
+		$header .= sprintf( '  %s', $segment->train_short, );
+	}
+
+	printf(
+		"%s  (%02d:%02d)  %s  %s%s\n\n",
+		$connection->dep
+		? $connection->dep->strftime('%d.%m. %H:%M')
+		: q{??.??. ??:??},
+		$connection->duration->in_units( 'hours', 'minutes' ),
+		$connection->arr ? $connection->arr->strftime('%H:%M') : q{??:??},
+		format_occupancy($connection),
+		$header,
+	);
+	for my $segment ( $connection->segments ) {
+		printf( "%s → %s\n", $segment->train_mid, $segment->direction );
+		printf( "%s  ab  %s\n",
+			$segment->dep->strftime('%H:%M'),
+			$segment->dep_name );
+		printf( "%s  an  %s\n",
+			$segment->arr->strftime('%H:%M'),
+			$segment->arr_name );
+		say q{};
+	}
+	say q{---------------------------------------};
+}
+
+__END__
+
+=head1 NAME
+
+dbris - Interface to bahn.de public transit routing service
+
+=head1 SYNOPSIS
+
+B<dbris> [B<-d> I<DD.MM.YYYY>] [B<-t> I<HH:MM>] I<from-stop> I<to-stop>
+
+=head1 VERSION
+
+version 0.01
+
+=head1 DESCRIPTION
+
+B<dbris-m> is an interface to the public transport services available on
+bahn.de. According to word of mouth, it uses the HAFAS backend that can also
+be accessed by Travel::Status::DE::HAFAS(3pm)'s DB service. However, the
+bahn.de entry point is likely more reliable in the long run.
+
+B<dbris-m> can serve as an arrival/departure monitor, request details about a
+specific trip, and look up public transport stops by name or geolocation. The
+operating mode depends on the contents of its non-option argument.
+
+=head2 Departure Monitor (I<station>)
+
+Show departures at I<station>. I<station> may be given as a station name or
+station ID.  For each departure, B<dbris-m> shows
+
+=over
+
+=item * estimated departure time,
+
+=item * delay, if known,
+
+=item * trip name, number, or line,
+
+=item * direction / destination, and
+
+=item * platform, if known.
+
+=back
+
+=head2 Trip details (I<JourneyID>)
+
+List intermediate stops of I<JourneyID> (as given by the departure monitor when
+invoed with B<-j> / B<--with-jid>) with arrival/departure time, delay (if
+available), occupancy (if available), and stop name. Also includes some generic
+trip information.
+
+=head2 Location Search (B<?>I<query>|I<lat>B<:>I<lon>)
+
+List stations that match I<query> or that are located in the vicinity of
+I<lat>B<:>I<lon> geocoordinates with station ID and name.
+
+=head1 OPTIONS
+
+Values in brackets indicate options that only apply to the corresponding
+operating mode(s).
+
+=over
+
+=item B<-d>, B<--date> I<DD.MM.[YYYY]> (departure monitor)
+
+Request departures on the specified date.
+Default: today.
+
+=item B<-j>, B<--with-jid> (departure monitor)
+
+Show JourneyID for each listed arrival/departure.
+These can be used to obtain details on individual trips with subsequent
+B<dbris-m> invocations.
+
+=item B<--json>
+
+Print result(s) as JSON and exit. This is a dump of internal data structures
+and not guaranteed to remain stable between minor versions. Please use the
+Travel::Status::DE::DBRIS(3pm) module if you need a proper API.
+
+=item B<--no-cache>
+
+By default, if the Cache::File module is available, server replies are cached
+for 90 seconds in F<~/.cache/Travel-Status-DE-DBRIS> (or a path relative to
+C<$XDG_CACHE_HOME>, if set). Use this option to disable caching. You can use
+B<--cache> to re-enable it.
+
+=item B<--raw-json>
+
+Print unprocessed API response as JSON and exit.
+Useful for debugging and development purposes.
+
+=item B<-t>, B<--date> I<HH:MM> (departure monitor)
+
+Request departures on or after the specified time.
+Default: now.
+
+=item B<-V>, B<--version>
+
+Show version information and exit.
+
+=back
+
+=head1 EXIT STATUS
+
+0 upon success, 1 upon internal error, 2 upon backend error.
+
+=head1 CONFIGURATION
+
+None.
+
+=head1 DEPENDENCIES
+
+=over
+
+=item * Class::Accessor(3pm)
+
+=item * DateTime(3pm)
+
+=item * LWP::UserAgent(3pm)
+
+=back
+
+=head1 BUGS AND LIMITATIONS
+
+=over
+
+=item * This module is very much work-in-progress
+
+=back
+
+=head1 AUTHOR
+
+Copyright (C) 2025 Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
+
+=head1 LICENSE
+
+This program is licensed under the same terms as Perl itself.
diff --git a/lib/Travel/Routing/DE/DBRIS.pm b/lib/Travel/Routing/DE/DBRIS.pm
new file mode 100644
index 0000000..aa4a476
--- /dev/null
+++ b/lib/Travel/Routing/DE/DBRIS.pm
@@ -0,0 +1,255 @@
+package Travel::Routing::DE::DBRIS;
+
+# vim:foldmethod=marker
+
+use strict;
+use warnings;
+use 5.020;
+use utf8;
+
+use parent 'Class::Accessor';
+
+use Carp qw(confess);
+use DateTime;
+use DateTime::Format::Strptime;
+use Encode qw(decode encode);
+use JSON;
+use LWP::UserAgent;
+use Travel::Status::DE::DBRIS;
+use Travel::Routing::DE::DBRIS::Connection;
+
+our $VERSION = '0.01';
+
+Travel::Routing::DE::DBRIS->mk_ro_accessors(qw(earlier later));
+
+# {{{ Constructors
+
+sub new {
+	my ( $obj, %conf ) = @_;
+	my $service = $conf{service};
+
+	my $ua = $conf{user_agent};
+
+	if ( not $ua ) {
+		my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } };
+		$ua = LWP::UserAgent->new(%lwp_options);
+		$ua->env_proxy;
+	}
+
+	my $self = {
+		developer_mode => $conf{developer_mode},
+		results        => [],
+		from           => $conf{from},
+		to             => $conf{to},
+		ua             => $ua,
+	};
+
+	bless( $self, $obj );
+
+	my $dt = $conf{datetime} // DateTime->now( time_zone => 'Europe/Berlin' );
+	my @mots
+	  = (qw(ICE EC_IC IR REGIONAL SBAHN BUS SCHIFF UBAHN TRAM ANRUFPFLICHTIG));
+	if ( $conf{modes_of_transit} ) {
+		@mots = @{ $conf{modes_of_transit} // [] };
+	}
+
+	my $req = {
+		abfahrtsHalt     => $conf{from}->id,
+		ankunftsHalt     => $conf{to}->id,
+		anfrageZeitpunkt => $dt->strftime('%Y-%m-%dT%H:%M:00'),
+		ankunftSuche     => 'ABFAHRT',
+		klasse           => 'KLASSE_2',
+		produktgattungen => \@mots,
+		reisende         => [
+			{
+				typ            => 'ERWACHSENER',
+				ermaessigungen => [
+					{
+						art    => 'KEINE_ERMAESSIGUNG',
+						klasse => 'KLASSENLOS'
+					},
+				],
+				alter  => [],
+				anzahl => 1,
+			}
+		],
+		schnelleVerbindungen              => \1,
+		sitzplatzOnly                     => \0,
+		bikeCarriage                      => \0,
+		reservierungsKontingenteVorhanden => \0,
+		nurDeutschlandTicketVerbindungen  => \0,
+		deutschlandTicketVorhanden        => \0
+	};
+
+	$self->{strptime_obj} //= DateTime::Format::Strptime->new(
+		pattern   => '%Y-%m-%dT%H:%M:%S',
+		time_zone => 'Europe/Berlin',
+	);
+
+	$self->{strpdate_obj} //= DateTime::Format::Strptime->new(
+		pattern   => '%Y-%m-%d',
+		time_zone => 'Europe/Berlin',
+	);
+
+	my $json = $self->{json} = JSON->new->utf8;
+
+	if ( $conf{async} ) {
+		$self->{req} = $req;
+		return $self;
+	}
+
+	if ( $conf{json} ) {
+		$self->{raw_json} = $conf{json};
+	}
+	else {
+		my $req_str = $json->encode($req);
+		if ( $self->{developer_mode} ) {
+			say "requesting $req_str";
+		}
+
+		my ( $content, $error )
+		  = $self->post_with_cache(
+			'https://www.bahn.de/web/api/angebote/fahrplan', $req_str );
+
+		if ($error) {
+			$self->{errstr} = $error;
+			return $self;
+		}
+
+		if ( $self->{developer_mode} ) {
+			say decode( 'utf-8', $content );
+		}
+
+		$self->{raw_json} = $json->decode($content);
+		$self->parse_connections;
+	}
+
+	return $self;
+}
+
+sub new_p {
+	my ( $obj, %conf ) = @_;
+	my $promise = $conf{promise}->new;
+
+	if (
+		not(    $conf{from}
+			and $conf{to} )
+	  )
+	{
+		return $promise->reject('"from" and "to" opts are mandatory');
+	}
+
+	my $self = $obj->new( %conf, async => 1 );
+	$self->{promise} = $conf{promise};
+
+	$self->post_with_cache_p( $self->{url} )->then(
+		sub {
+			my ($content) = @_;
+			$self->{raw_json} = $self->{json}->decode($content);
+			$self->parse_connections;
+			$promise->resolve($self);
+			return;
+		}
+	)->catch(
+		sub {
+			my ($err) = @_;
+			$promise->reject( $err, $self );
+			return;
+		}
+	)->wait;
+
+	return $promise;
+}
+
+# }}}
+# {{{ Internal Helpers
+
+sub post_with_cache {
+	my ( $self, $url, $req ) = @_;
+	my $cache = $self->{cache};
+
+	if ( $self->{developer_mode} ) {
+		say "POST $url $req";
+	}
+
+	if ($cache) {
+		my $content = $cache->thaw($url);
+		if ($content) {
+			if ( $self->{developer_mode} ) {
+				say '  cache hit';
+			}
+			return ( ${$content}, undef );
+		}
+	}
+
+	if ( $self->{developer_mode} ) {
+		say '  cache miss';
+	}
+
+	my $reply = $self->{ua}->post(
+		$url,
+		Accept           => 'application/json',
+		'Content-Type'   => 'application/json; charset=utf-8',
+		Origin           => 'https://www.bahn.de',
+		Referer          => 'https://www.bahn.de/buchung/fahrplan/suche',
+		'Sec-Fetch-Dest' => 'empty',
+		'Sec-Fetch-Mode' => 'cors',
+		'Sec-Fetch-Site' => 'same-origin',
+		TE               => 'trailers',
+		Content          => $req,
+	);
+
+	if ( $reply->is_error ) {
+		say $reply->status_line;
+		return ( undef, $reply->status_line );
+	}
+	my $content = $reply->content;
+
+	if ($cache) {
+		$cache->freeze( $url, \$content );
+	}
+
+	return ( $content, undef );
+}
+
+sub post_with_cache_p {
+	...;
+}
+
+sub parse_connections {
+	my ($self) = @_;
+
+	my $json = $self->{raw_json};
+
+	$self->{earlier} = $json->{verbindungReference}{earlier};
+	$self->{later}   = $json->{verbindungReference}{later};
+
+	for my $connection ( @{ $json->{verbindungen} // [] } ) {
+		push(
+			@{ $self->{connections} },
+			Travel::Routing::DE::DBRIS::Connection->new(
+				json         => $connection,
+				strpdate_obj => $self->{strpdate_obj},
+				strptime_obj => $self->{strptime_obj}
+			)
+		);
+	}
+}
+
+# }}}
+# {{{ Public Functions
+
+sub errstr {
+	my ($self) = @_;
+
+	return $self->{errstr};
+}
+
+sub connections {
+	my ($self) = @_;
+	return @{ $self->{connections} };
+}
+
+# }}}
+
+1;
diff --git a/lib/Travel/Routing/DE/DBRIS/Connection.pm b/lib/Travel/Routing/DE/DBRIS/Connection.pm
new file mode 100644
index 0000000..f516729
--- /dev/null
+++ b/lib/Travel/Routing/DE/DBRIS/Connection.pm
@@ -0,0 +1,107 @@
+package Travel::Routing::DE::DBRIS::Connection;
+
+use strict;
+use warnings;
+use 5.020;
+
+use parent 'Class::Accessor';
+
+use DateTime::Duration;
+use Travel::Routing::DE::DBRIS::Connection::Segment;
+
+our $VERSION = '0.01';
+
+Travel::Routing::DE::DBRIS::Connection->mk_ro_accessors(
+	qw(changes
+	  duration sched_duration rt_duration
+	  sched_dep rt_dep dep
+	  sched_arr rt_arr arr
+	  occupancy occupancy_first occupancy_second)
+);
+
+sub new {
+	my ( $obj, %opt ) = @_;
+
+	my $json     = $opt{json};
+	my $strpdate = $opt{strpdate_obj};
+	my $strptime = $opt{strptime_obj};
+
+	my $ref = {
+		changes      => $json->{umstiegsAnzahl},
+		id           => $json->{tripId},
+		strptime_obj => $strptime,
+	};
+
+	if ( my $d = $json->{verbindungsDauerInSeconds} ) {
+		$ref->{sched_duration} = DateTime::Duration->new(
+			hours   => int( $d / 3600 ),
+			minutes => int( ( $d % 3600 ) / 60 ),
+			seconds => $d % 60,
+		);
+	}
+	if ( my $d = $json->{ezVerbindungsDauerInSeconds} ) {
+		$ref->{rt_duration} = DateTime::Duration->new(
+			hours   => int( $d / 3600 ),
+			minutes => int( ( $d % 3600 ) / 60 ),
+			seconds => $d % 60,
+		);
+	}
+	$ref->{duration} = $ref->{rt_duration} // $ref->{sched_duration};
+
+	for my $occupancy ( @{ $json->{auslastungsmeldungen} // [] } ) {
+		if ( $occupancy->{klasse} eq 'KLASSE_1' ) {
+			$ref->{occupancy_first} = $occupancy->{stufe};
+		}
+		if ( $occupancy->{klasse} eq 'KLASSE_2' ) {
+			$ref->{occupancy_second} = $occupancy->{stufe};
+		}
+	}
+
+	if ( $ref->{occupancy_first} and $ref->{occupancy_second} ) {
+		$ref->{occupancy}
+		  = ( $ref->{occupancy_first} + $ref->{occupancy_second} ) / 2;
+	}
+	elsif ( $ref->{occupancy_first} ) {
+		$ref->{occupancy} = $ref->{occupancy_first};
+	}
+	elsif ( $ref->{occupancy_second} ) {
+		$ref->{occupancy} = $ref->{occupancy_second};
+	}
+
+	for my $segment ( @{ $json->{verbindungsAbschnitte} // [] } ) {
+		push(
+			@{ $ref->{segments} },
+			Travel::Routing::DE::DBRIS::Connection::Segment->new(
+				json         => $segment,
+				strptime_obj => $strptime
+			)
+		);
+	}
+
+	for my $key (qw(sched_dep rt_dep dep)) {
+		$ref->{$key} = $ref->{segments}[0]{$key};
+	}
+	for my $key (qw(sched_arr rt_arr arr)) {
+		$ref->{$key} = $ref->{segments}[-1]{$key};
+	}
+
+	bless( $ref, $obj );
+
+	return $ref;
+}
+
+sub segments {
+	my ($self) = @_;
+
+	return @{ $self->{segments} // [] };
+}
+
+sub TO_JSON {
+	my ($self) = @_;
+
+	my $ret = { %{$self} };
+
+	return $ret;
+}
+
+1;
diff --git a/lib/Travel/Routing/DE/DBRIS/Connection/Segment.pm b/lib/Travel/Routing/DE/DBRIS/Connection/Segment.pm
new file mode 100644
index 0000000..b8134bb
--- /dev/null
+++ b/lib/Travel/Routing/DE/DBRIS/Connection/Segment.pm
@@ -0,0 +1,79 @@
+package Travel::Routing::DE::DBRIS::Connection::Segment;
+
+use strict;
+use warnings;
+use 5.020;
+
+use parent 'Class::Accessor';
+
+use DateTime::Duration;
+
+our $VERSION = '0.01';
+
+Travel::Routing::DE::DBRIS::Connection::Segment->mk_ro_accessors(
+	qw(
+	  dep_name dep_eva arr_name arr_eva
+	  train train_long train_mid train_short direction
+	  sched_dep rt_dep dep
+	  sched_arr rt_arr arr
+	  sched_duration rt_duration duration duration_percent
+	  journey_id
+	)
+);
+
+sub new {
+	my ( $obj, %opt ) = @_;
+
+	my $json     = $opt{json};
+	my $strptime = $opt{strptime_obj};
+
+	my $ref = {
+		arr_eva     => $json->{ankunftsOrtExtId},
+		arr_name    => $json->{ankunftsOrt},
+		dep_eva     => $json->{abfahrtsOrtExtId},
+		dep_name    => $json->{abfahrtsOrt},
+		train       => $json->{verkehrsmittel}{name},
+		train_short => $json->{verkehrsmittel}{kurzText},
+		train_mid   => $json->{verkehrsmittel}{mittelText},
+		train_long  => $json->{verkehrsmittel}{langText},
+		direction   => $json->{verkehrsmittel}{richtung},
+	};
+
+	if ( my $ts = $json->{abfahrtsZeitpunkt} ) {
+		$ref->{sched_dep} = $strptime->parse_datetime($ts);
+	}
+	if ( my $ts = $json->{ezAbfahrtsZeitpunkt} ) {
+		$ref->{rt_dep} = $strptime->parse_datetime($ts);
+	}
+	$ref->{dep} = $ref->{rt_dep} // $ref->{sched_dep};
+
+	if ( my $ts = $json->{ankunftsZeitpunkt} ) {
+		$ref->{sched_arr} = $strptime->parse_datetime($ts);
+	}
+	if ( my $ts = $json->{ezAnkunftsZeitpunkt} ) {
+		$ref->{rt_arr} = $strptime->parse_datetime($ts);
+	}
+	$ref->{arr} = $ref->{rt_arr} // $ref->{sched_arr};
+
+	if ( my $d = $json->{abschnittsDauerInSeconds} ) {
+		$ref->{sched_duration} = DateTime::Duration->new(
+			hours   => int( $d / 3600 ),
+			minutes => int( ( $d % 3600 ) / 60 ),
+			seconds => $d % 60,
+		);
+	}
+	if ( my $d = $json->{ezAbschnittsDauerInSeconds} ) {
+		$ref->{rt_duration} = DateTime::Duration->new(
+			hours   => int( $d / 3600 ),
+			minutes => int( ( $d % 3600 ) / 60 ),
+			seconds => $d % 60,
+		);
+	}
+	$ref->{duration} = $ref->{rt_duration} // $ref->{sched_duration};
+
+	bless( $ref, $obj );
+
+	return $ref;
+}
+
+1;